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 Prelude
  43 import Text.ParserCombinators.Parsec.Pos
  44 import Text.ParserCombinators.Parsec.Error
  45 import Control.Monad
  46
  47 {-# INLINE parsecMap    #-}
  48 {-# INLINE parsecReturn #-}
  49 {-# INLINE parsecBind   #-}
  50 {-# INLINE parsecZero   #-}
  51 {-# INLINE parsecPlus   #-}
  52 {-# INLINE token        #-}
  53 {-# INLINE tokenPrim    #-}
  54
  55 -----------------------------------------------------------
  56 -- Operators:
  57 -- <?>  gives a name to a parser (which is used in error messages)
  58 -- <|>  is the choice operator
  59 -----------------------------------------------------------
  60 infix  0 <?>
  61 infixr 1 <|>
  62
  63 (<?>) :: GenParser tok st a -> String -> GenParser tok st a
  64 p <?> msg           = label p msg
  65
  66 (<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
  67 p1 <|> p2           = mplus p1 p2
  68
  69
  70 -----------------------------------------------------------
  71 -- User state combinators
  72 -----------------------------------------------------------
  73 getState :: GenParser tok st st
  74 getState        = do{ state <- getParserState
  75                     ; return (stateUser state)
  76                     }
  77
  78 setState :: st -> GenParser tok st ()
  79 setState st     = do{ updateParserState (\(State input pos _) -> State input pos st)
  80                     ; return ()
  81                     }
  82
  83 updateState :: (st -> st) -> GenParser tok st ()
  84 updateState f   = do{ updateParserState (\(State input pos user) -> State input pos (f user))
  85                     ; return ()
  86                     }
  87
  88
  89 -----------------------------------------------------------
  90 -- Parser state combinators
  91 -----------------------------------------------------------
  92 getPosition :: GenParser tok st SourcePos
  93 getPosition         = do{ state <- getParserState; return (statePos state) }
  94
  95 getInput :: GenParser tok st [tok]
  96 getInput            = do{ state <- getParserState; return (stateInput state) }
  97
  98
  99 setPosition :: SourcePos -> GenParser tok st ()
 100 setPosition pos     = do{ updateParserState (\(State input _ user) -> State input pos user)
 101                         ; return ()
 102                         }
 103
 104 setInput :: [tok] -> GenParser tok st ()
 105 setInput input      = do{ updateParserState (\(State _ pos user) -> State input pos user)
 106                         ; return ()
 107                         }
 108
 109 getParserState      :: GenParser tok st (State tok st)
 110 getParserState      =  updateParserState id
 111
 112 setParserState      :: State tok st -> GenParser tok st (State tok st)
 113 setParserState st   = updateParserState (const st)
 114
 115
 116
 117
 118 -----------------------------------------------------------
 119 -- Parser definition.
 120 -- GenParser tok st a:
 121 --  General parser for tokens of type "tok",
 122 --  a user state "st" and a result type "a"
 123 -----------------------------------------------------------
 124 type Parser a           = GenParser Char () a
 125
 126 newtype GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a))
 127 runP (Parser p)            = p
 128
 129 data Consumed a         = Consumed a                --input is consumed
 130                         | Empty !a                  --no input is consumed
 131
 132 data Reply tok st a     = Ok a (State tok st) ParseError      --parsing succeeded with "a"
 133                         | Error ParseError                    --parsing failed
 134
 135 data State tok st       = State { stateInput :: [tok]
 136                                 , statePos   :: SourcePos
 137                                 , stateUser  :: !st
 138                                 }
 139
 140
 141 -----------------------------------------------------------
 142 -- run a parser
 143 -----------------------------------------------------------
 144 parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)
 145 parseFromFile p fname
 146     = do{ input <- readFile fname
 147         ; return (parse p fname input)
 148         }
 149
 150 parseTest :: Show a => GenParser tok () a -> [tok] -> IO ()
 151 parseTest p input
 152     = case (runParser p () "" input) of
 153         Left err -> do{ putStr "parse error at "
 154                       ; print err
 155                       }
 156         Right x  -> print x
 157
 158
 159 parse :: GenParser tok () a -> SourceName -> [tok] -> Either ParseError a
 160 parse p name input
 161     = runParser p () name input
 162
 163
 164 runParser :: GenParser tok st a -> st -> SourceName -> [tok] -> Either ParseError a
 165 runParser p st name input
 166     = case parserReply (runP p (State input (initialPos name) st)) of
 167         Ok x _ _    -> Right x
 168         Error err   -> Left err
 169
 170 parserReply result
 171     = case result of
 172         Consumed reply -> reply
 173         Empty reply    -> reply
 174
 175
 176 -----------------------------------------------------------
 177 -- Functor: fmap
 178 -----------------------------------------------------------
 179 instance Functor (GenParser tok st) where
 180   fmap f p  = parsecMap f p
 181
 182 parsecMap :: (a -> b) -> GenParser tok st a -> GenParser tok st b
 183 parsecMap f (Parser p)
 184     = Parser (\state ->
 185         case (p state) of
 186           Consumed reply -> Consumed (mapReply reply)
 187           Empty    reply -> Empty    (mapReply reply)
 188       )
 189     where
 190       mapReply reply
 191         = case reply of
 192             Ok x state err -> let fx = f x
 193                               in seq fx (Ok fx state err)
 194             Error err      -> Error err
 195
 196
 197 -----------------------------------------------------------
 198 -- Monad: return, sequence (>>=) and fail
 199 -----------------------------------------------------------
 200 instance Monad (GenParser tok st) where
 201   return x   = parsecReturn x
 202   p >>= f    = parsecBind p f
 203   fail msg   = parsecFail msg
 204
 205 parsecReturn :: a -> GenParser tok st a
 206 parsecReturn x
 207   = Parser (\state -> Empty (Ok x state (unknownError state)))
 208
 209 parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b
 210 parsecBind (Parser p) f
 211     = Parser (\state ->
 212         case (p state) of
 213           Consumed reply1
 214             -> Consumed $
 215                case (reply1) of
 216                  Ok x state1 err1 -> case runP (f x) state1 of
 217                                        Empty reply2    -> mergeErrorReply err1 reply2
 218                                        Consumed reply2 -> reply2
 219                  Error err1       -> Error err1
 220
 221           Empty reply1
 222             -> case (reply1) of
 223                  Ok x state1 err1 -> case runP (f x) state1 of
 224                                        Empty reply2 -> Empty (mergeErrorReply err1 reply2)
 225                                        other        -> other
 226                  Error err1       -> Empty (Error err1)
 227       )
 228
 229 mergeErrorReply err1 reply
 230   = case reply of
 231       Ok x state err2 -> Ok x state (mergeError err1 err2)
 232       Error err2      -> Error (mergeError err1 err2)
 233
 234
 235 parsecFail :: String -> GenParser tok st a
 236 parsecFail msg
 237   = Parser (\state ->
 238       Empty (Error (newErrorMessage (Message msg) (statePos state))))
 239
 240
 241 -----------------------------------------------------------
 242 -- MonadPlus: alternative (mplus) and mzero
 243 -----------------------------------------------------------
 244 instance MonadPlus (GenParser tok st) where
 245   mzero         = parsecZero
 246   mplus p1 p2   = parsecPlus p1 p2
 247
 248
 249 pzero :: GenParser tok st a
 250 pzero = parsecZero
 251
 252 parsecZero :: GenParser tok st a
 253 parsecZero
 254     = Parser (\state -> Empty (Error (unknownError state)))
 255
 256 parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
 257 parsecPlus (Parser p1) (Parser p2)
 258     = Parser (\state ->
 259         case (p1 state) of
 260           Empty (Error err) -> case (p2 state) of
 261                                  Empty reply -> Empty (mergeErrorReply err reply)
 262                                  consumed    -> consumed
 263           other             -> other
 264       )
 265
 266
 267 {-
 268 -- variant that favors a consumed reply over an empty one, even it is not the first alternative.
 269           empty@(Empty reply) -> case reply of
 270                                    Error err ->
 271                                      case (p2 state) of
 272                                        Empty reply -> Empty (mergeErrorReply err reply)
 273                                        consumed    -> consumed
 274                                    ok ->
 275                                      case (p2 state) of
 276                                        Empty reply -> empty
 277                                        consumed    -> consumed
 278           consumed  -> consumed
 279 -}
 280
 281
 282 -----------------------------------------------------------
 283 -- Primitive Parsers:
 284 --  try, token(Prim), label, unexpected and updateState
 285 -----------------------------------------------------------
 286 try :: GenParser tok st a -> GenParser tok st a
 287 try (Parser p)
 288     = Parser (\state@(State input pos user) ->
 289         case (p state) of
 290           Consumed (Error err)  -> Empty (Error (setErrorPos pos err))
 291           Consumed ok           -> Consumed ok    -- was: Empty ok
 292           empty                 -> empty
 293       )
 294
 295
 296 token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
 297 token show tokpos test
 298   = tokenPrim show nextpos test
 299   where
 300     nextpos _ _   (tok:toks)  = tokpos tok
 301     nextpos _ tok []          = tokpos tok
 302
 303 tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
 304 tokenPrim show nextpos test
 305     = Parser (\state@(State input pos user) ->
 306         case input of
 307           (c:cs) -> case test c of
 308                       Just x  -> let newpos   = nextpos pos c cs
 309                                      newstate = State cs newpos user
 310                                  in seq newpos $ seq newstate $
 311                                     Consumed (Ok x newstate (newErrorUnknown newpos))
 312                       Nothing -> Empty (sysUnExpectError (show c) pos)
 313           []     -> Empty (sysUnExpectError "" pos)
 314       )
 315
 316
 317 label :: GenParser tok st a -> String -> GenParser tok st a
 318 label p msg
 319   = labels p [msg]
 320
 321 labels :: GenParser tok st a -> [String] -> GenParser tok st a
 322 labels (Parser p) msgs
 323     = Parser (\state ->
 324         case (p state) of
 325           Empty reply -> Empty $
 326                          case (reply) of
 327                            Error err        -> Error (setExpectErrors err msgs)
 328                            Ok x state1 err  | errorIsUnknown err -> reply
 329                                             | otherwise -> Ok x state1 (setExpectErrors err msgs)
 330           other       -> other
 331       )
 332
 333
 334 updateParserState :: (State tok st -> State tok st) -> GenParser tok st (State tok st)
 335 updateParserState f
 336     = Parser (\state -> let newstate = f state
 337                         in seq newstate $
 338                            Empty (Ok state newstate (unknownError newstate)))
 339
 340
 341 unexpected :: String -> GenParser tok st a
 342 unexpected msg
 343     = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state))))
 344
 345
 346 setExpectErrors err []         = setErrorMessage (Expect "") err
 347 setExpectErrors err [msg]      = setErrorMessage (Expect msg) err
 348 setExpectErrors err (msg:msgs) = foldr (\msg err -> addErrorMessage (Expect msg) err)
 349                                        (setErrorMessage (Expect msg) err) msgs
 350
 351 sysUnExpectError msg pos  = Error (newErrorMessage (SysUnExpect msg) pos)
 352 unknownError state        = newErrorUnknown (statePos state)
 353
 354 -----------------------------------------------------------
 355 -- Parsers unfolded for space:
 356 -- if many and skipMany are not defined as primitives,
 357 -- they will overflow the stack on large inputs
 358 -----------------------------------------------------------
 359 many :: GenParser tok st a -> GenParser tok st [a]
 360 many p
 361   = do{ xs <- manyAccum (:) p
 362       ; return (reverse xs)
 363       }
 364
 365 skipMany :: GenParser tok st a -> GenParser tok st ()
 366 skipMany p
 367   = do{ manyAccum (\x xs -> []) p
 368       ; return ()
 369       }
 370
 371 manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a]
 372 manyAccum accum (Parser p)
 373   = Parser (\state ->
 374     let walk xs state r = case r of
 375                            Empty (Error err)          -> Ok xs state err
 376                            Empty ok                   -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
 377                            Consumed (Error err)       -> Error err
 378                            Consumed (Ok x state' err) -> let ys = accum x xs
 379                                                          in seq ys (walk ys state' (p state'))
 380     in case (p state) of
 381          Empty reply  -> case reply of
 382                            Ok x state' err -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
 383                            Error err       -> Empty (Ok [] state err)
 384          consumed     -> Consumed $ walk [] state consumed)
 385
 386
 387
 388 -----------------------------------------------------------
 389 -- Parsers unfolded for speed:
 390 --  tokens
 391 -----------------------------------------------------------
 392
 393 {- specification of @tokens@:
 394 tokens showss nextposs s
 395   = scan s
 396   where
 397     scan []       = return s
 398     scan (c:cs)   = do{ token show nextpos c <?> shows s; scan cs }
 399
 400     show c        = shows [c]
 401     nextpos pos c = nextposs pos [c]
 402 -}
 403
 404 tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok]
 405 tokens shows nextposs s
 406     = Parser (\state@(State input pos user) ->
 407        let
 408         ok cs             = let newpos   = nextposs pos s
 409                                 newstate = State cs newpos user
 410                             in seq newpos $ seq newstate $
 411                                (Ok s newstate (newErrorUnknown newpos))
 412
 413         errEof            = Error (setErrorMessage (Expect (shows s))
 414                                      (newErrorMessage (SysUnExpect "") pos))
 415         errExpect c       = Error (setErrorMessage (Expect (shows s))
 416                                      (newErrorMessage (SysUnExpect (shows [c])) pos))
 417
 418         walk [] cs        = ok cs
 419         walk xs []        = errEof
 420         walk (x:xs) (c:cs)| x == c        = walk xs cs
 421                           | otherwise     = errExpect c
 422
 423         walk1 [] cs        = Empty (ok cs)
 424         walk1 xs []        = Empty (errEof)
 425         walk1 (x:xs) (c:cs)| x == c        = Consumed (walk xs cs)
 426                            | otherwise     = Empty (errExpect c)
 427
 428        in walk1 s input)
 429
 430