1-- | 2-- Module : Text.Megaparsec.Class 3-- Copyright : © 2015–2019 Megaparsec contributors 4-- © 2007 Paolo Martini 5-- © 1999–2001 Daan Leijen 6-- License : FreeBSD 7-- 8-- Maintainer : Mark Karpov <markkarpov92@gmail.com> 9-- Stability : experimental 10-- Portability : portable 11-- 12-- Definition of 'MonadParsec'—type class describing monads that implement 13-- the full set of primitive parsers. 14-- 15-- @since 6.5.0 16 17{-# LANGUAGE CPP #-} 18{-# LANGUAGE FlexibleInstances #-} 19{-# LANGUAGE FunctionalDependencies #-} 20{-# LANGUAGE MultiParamTypeClasses #-} 21{-# LANGUAGE TupleSections #-} 22{-# LANGUAGE UndecidableInstances #-} 23 24module Text.Megaparsec.Class 25 ( MonadParsec (..) ) 26where 27 28import Control.Monad 29import Control.Monad.Identity 30import Control.Monad.Trans 31import Data.Set (Set) 32import Text.Megaparsec.Error 33import Text.Megaparsec.State 34import Text.Megaparsec.Stream 35import qualified Control.Monad.RWS.Lazy as L 36import qualified Control.Monad.RWS.Strict as S 37import qualified Control.Monad.Trans.Reader as L 38import qualified Control.Monad.Trans.State.Lazy as L 39import qualified Control.Monad.Trans.State.Strict as S 40import qualified Control.Monad.Trans.Writer.Lazy as L 41import qualified Control.Monad.Trans.Writer.Strict as S 42 43#if !MIN_VERSION_mtl(2,2,2) 44import Control.Monad.Trans.Identity 45#endif 46 47-- | Type class describing monads that implement the full set of primitive 48-- parsers. 49-- 50-- __Note carefully__ that the following primitives are “fast” and should be 51-- taken advantage of as much as possible if your aim is a fast parser: 52-- 'tokens', 'takeWhileP', 'takeWhile1P', and 'takeP'. 53 54class (Stream s, MonadPlus m) => MonadParsec e s m | m -> e s where 55 56 -- | The most general way to stop parsing and report a trivial 57 -- 'ParseError'. 58 -- 59 -- @since 6.0.0 60 61 failure 62 :: Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any) 63 -> Set (ErrorItem (Token s)) -- ^ Expected items 64 -> m a 65 66 -- | The most general way to stop parsing and report a fancy 'ParseError'. 67 -- To report a single custom parse error, see 68 -- 'Text.Megaparsec.customFailure'. 69 -- 70 -- @since 6.0.0 71 72 fancyFailure 73 :: Set (ErrorFancy e) -- ^ Fancy error components 74 -> m a 75 76 -- | The parser @'label' name p@ behaves as parser @p@, but whenever the 77 -- parser @p@ fails /without consuming any input/, it replaces names of 78 -- “expected” tokens with the name @name@. 79 80 label :: String -> m a -> m a 81 82 -- | @'hidden' p@ behaves just like parser @p@, but it doesn't show any 83 -- “expected” tokens in error message when @p@ fails. 84 -- 85 -- Please use 'hidden' instead of the old @'label' ""@ idiom. 86 87 hidden :: m a -> m a 88 hidden = label "" 89 90 -- | The parser @'try' p@ behaves like parser @p@, except that it 91 -- backtracks the parser state when @p@ fails (either consuming input or 92 -- not). 93 -- 94 -- This combinator is used whenever arbitrary look ahead is needed. Since 95 -- it pretends that it hasn't consumed any input when @p@ fails, the 96 -- ('A.<|>') combinator will try its second alternative even if the first 97 -- parser failed while consuming input. 98 -- 99 -- For example, here is a parser that is supposed to parse the word “let” 100 -- or the word “lexical”: 101 -- 102 -- >>> parseTest (string "let" <|> string "lexical") "lexical" 103 -- 1:1: 104 -- unexpected "lex" 105 -- expecting "let" 106 -- 107 -- What happens here? The first parser consumes “le” and fails (because it 108 -- doesn't see a “t”). The second parser, however, isn't tried, since the 109 -- first parser has already consumed some input! 'try' fixes this behavior 110 -- and allows backtracking to work: 111 -- 112 -- >>> parseTest (try (string "let") <|> string "lexical") "lexical" 113 -- "lexical" 114 -- 115 -- 'try' also improves error messages in case of overlapping alternatives, 116 -- because Megaparsec's hint system can be used: 117 -- 118 -- >>> parseTest (try (string "let") <|> string "lexical") "le" 119 -- 1:1: 120 -- unexpected "le" 121 -- expecting "let" or "lexical" 122 -- 123 -- __Please note__ that as of Megaparsec 4.4.0, 124 -- 'Text.Megaparsec.Char.string' backtracks automatically (see 'tokens'), 125 -- so it does not need 'try'. However, the examples above demonstrate the 126 -- idea behind 'try' so well that it was decided to keep them. You still 127 -- need to use 'try' when your alternatives are complex, composite 128 -- parsers. 129 130 try :: m a -> m a 131 132 -- | If @p@ in @'lookAhead' p@ succeeds (either consuming input or not) 133 -- the whole parser behaves like @p@ succeeded without consuming anything 134 -- (parser state is not updated as well). If @p@ fails, 'lookAhead' has no 135 -- effect, i.e. it will fail consuming input if @p@ fails consuming input. 136 -- Combine with 'try' if this is undesirable. 137 138 lookAhead :: m a -> m a 139 140 -- | @'notFollowedBy' p@ only succeeds when the parser @p@ fails. This 141 -- parser /never consumes/ any input and /never modifies/ parser state. It 142 -- can be used to implement the “longest match” rule. 143 144 notFollowedBy :: m a -> m () 145 146 -- | @'withRecovery' r p@ allows continue parsing even if parser @p@ 147 -- fails. In this case @r@ is called with the actual 'ParseError' as its 148 -- argument. Typical usage is to return a value signifying failure to 149 -- parse this particular object and to consume some part of the input up 150 -- to the point where the next object starts. 151 -- 152 -- Note that if @r@ fails, original error message is reported as if 153 -- without 'withRecovery'. In no way recovering parser @r@ can influence 154 -- error messages. 155 -- 156 -- @since 4.4.0 157 158 withRecovery 159 :: (ParseError s e -> m a) -- ^ How to recover from failure 160 -> m a -- ^ Original parser 161 -> m a -- ^ Parser that can recover from failures 162 163 -- | @'observing' p@ allows to “observe” failure of the @p@ parser, should 164 -- it happen, without actually ending parsing but instead getting the 165 -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right' 166 -- as usual. Note that this primitive just allows you to observe parse 167 -- errors as they happen, it does not backtrack or change how the @p@ 168 -- parser works in any way. 169 -- 170 -- @since 5.1.0 171 172 observing 173 :: m a -- ^ The parser to run 174 -> m (Either (ParseError s e) a) 175 176 -- | This parser only succeeds at the end of input. 177 178 eof :: m () 179 180 -- | The parser @'token' test expected@ accepts a token @t@ with result 181 -- @x@ when the function @test t@ returns @'Just' x@. @expected@ specifies 182 -- the collection of expected items to report in error messages. 183 -- 184 -- This is the most primitive combinator for accepting tokens. For 185 -- example, the 'Text.Megaparsec.satisfy' parser is implemented as: 186 -- 187 -- > satisfy f = token testToken E.empty 188 -- > where 189 -- > testToken x = if f x then Just x else Nothing 190 -- 191 -- __Note__: type signature of this primitive was changed in the version 192 -- /7.0.0/. 193 194 token 195 :: (Token s -> Maybe a) 196 -- ^ Matching function for the token to parse 197 -> Set (ErrorItem (Token s)) 198 -- ^ Expected items (in case of an error) 199 -> m a 200 201 -- | The parser @'tokens' test chk@ parses a chunk of input @chk@ and 202 -- returns it. The supplied predicate @test@ is used to check equality of 203 -- given and parsed chunks after a candidate chunk of correct length is 204 -- fetched from the stream. 205 -- 206 -- This can be used for example to write 'Text.Megaparsec.chunk': 207 -- 208 -- > chunk = tokens (==) 209 -- 210 -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking 211 -- primitive, which means that if it fails, it never consumes any input. 212 -- This is done to make its consumption model match how error messages for 213 -- this primitive are reported (which becomes an important thing as user 214 -- gets more control with primitives like 'withRecovery'): 215 -- 216 -- >>> parseTest (string "abc") "abd" 217 -- 1:1: 218 -- unexpected "abd" 219 -- expecting "abc" 220 -- 221 -- This means, in particular, that it's no longer necessary to use 'try' 222 -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and 223 -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect 224 -- performance in any way. 225 226 tokens 227 :: (Tokens s -> Tokens s -> Bool) 228 -- ^ Predicate to check equality of chunks 229 -> Tokens s 230 -- ^ Chunk of input to match against 231 -> m (Tokens s) 232 233 -- | Parse /zero/ or more tokens for which the supplied predicate holds. 234 -- Try to use this as much as possible because for many streams the 235 -- combinator is much faster than parsers built with 236 -- 'Control.Monad.Combinators.many' and 'Text.Megaparsec.satisfy'. 237 -- 238 -- The following equations should clarify the behavior: 239 -- 240 -- > takeWhileP (Just "foo") f = many (satisfy f <?> "foo") 241 -- > takeWhileP Nothing f = many (satisfy f) 242 -- 243 -- The combinator never fails, although it may parse the empty chunk. 244 -- 245 -- @since 6.0.0 246 247 takeWhileP 248 :: Maybe String -- ^ Name for a single token in the row 249 -> (Token s -> Bool) -- ^ Predicate to use to test tokens 250 -> m (Tokens s) -- ^ A chunk of matching tokens 251 252 -- | Similar to 'takeWhileP', but fails if it can't parse at least one 253 -- token. Note that the combinator either succeeds or fails without 254 -- consuming any input, so 'try' is not necessary with it. 255 -- 256 -- @since 6.0.0 257 258 takeWhile1P 259 :: Maybe String -- ^ Name for a single token in the row 260 -> (Token s -> Bool) -- ^ Predicate to use to test tokens 261 -> m (Tokens s) -- ^ A chunk of matching tokens 262 263 -- | Extract the specified number of tokens from the input stream and 264 -- return them packed as a chunk of stream. If there is not enough tokens 265 -- in the stream, a parse error will be signaled. It's guaranteed that if 266 -- the parser succeeds, the requested number of tokens will be returned. 267 -- 268 -- The parser is roughly equivalent to: 269 -- 270 -- > takeP (Just "foo") n = count n (anyChar <?> "foo") 271 -- > takeP Nothing n = count n anyChar 272 -- 273 -- Note that if the combinator fails due to insufficient number of tokens 274 -- in the input stream, it backtracks automatically. No 'try' is necessary 275 -- with 'takeP'. 276 -- 277 -- @since 6.0.0 278 279 takeP 280 :: Maybe String -- ^ Name for a single token in the row 281 -> Int -- ^ How many tokens to extract 282 -> m (Tokens s) -- ^ A chunk of matching tokens 283 284 -- | Return the full parser state as a 'State' record. 285 286 getParserState :: m (State s) 287 288 -- | @'updateParserState' f@ applies the function @f@ to the parser state. 289 290 updateParserState :: (State s -> State s) -> m () 291 292---------------------------------------------------------------------------- 293-- Lifting through MTL 294 295instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where 296 failure us ps = lift (failure us ps) 297 fancyFailure xs = lift (fancyFailure xs) 298 label n (L.StateT m) = L.StateT $ label n . m 299 try (L.StateT m) = L.StateT $ try . m 300 lookAhead (L.StateT m) = L.StateT $ \s -> 301 (,s) . fst <$> lookAhead (m s) 302 notFollowedBy (L.StateT m) = L.StateT $ \s -> 303 notFollowedBy (fst <$> m s) >> return ((),s) 304 withRecovery r (L.StateT m) = L.StateT $ \s -> 305 withRecovery (\e -> L.runStateT (r e) s) (m s) 306 observing (L.StateT m) = L.StateT $ \s -> 307 fixs s <$> observing (m s) 308 eof = lift eof 309 token test mt = lift (token test mt) 310 tokens e ts = lift (tokens e ts) 311 takeWhileP l f = lift (takeWhileP l f) 312 takeWhile1P l f = lift (takeWhile1P l f) 313 takeP l n = lift (takeP l n) 314 getParserState = lift getParserState 315 updateParserState f = lift (updateParserState f) 316 317instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where 318 failure us ps = lift (failure us ps) 319 fancyFailure xs = lift (fancyFailure xs) 320 label n (S.StateT m) = S.StateT $ label n . m 321 try (S.StateT m) = S.StateT $ try . m 322 lookAhead (S.StateT m) = S.StateT $ \s -> 323 (,s) . fst <$> lookAhead (m s) 324 notFollowedBy (S.StateT m) = S.StateT $ \s -> 325 notFollowedBy (fst <$> m s) >> return ((),s) 326 withRecovery r (S.StateT m) = S.StateT $ \s -> 327 withRecovery (\e -> S.runStateT (r e) s) (m s) 328 observing (S.StateT m) = S.StateT $ \s -> 329 fixs s <$> observing (m s) 330 eof = lift eof 331 token test mt = lift (token test mt) 332 tokens e ts = lift (tokens e ts) 333 takeWhileP l f = lift (takeWhileP l f) 334 takeWhile1P l f = lift (takeWhile1P l f) 335 takeP l n = lift (takeP l n) 336 getParserState = lift getParserState 337 updateParserState f = lift (updateParserState f) 338 339instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where 340 failure us ps = lift (failure us ps) 341 fancyFailure xs = lift (fancyFailure xs) 342 label n (L.ReaderT m) = L.ReaderT $ label n . m 343 try (L.ReaderT m) = L.ReaderT $ try . m 344 lookAhead (L.ReaderT m) = L.ReaderT $ lookAhead . m 345 notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m 346 withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> 347 withRecovery (\e -> L.runReaderT (r e) s) (m s) 348 observing (L.ReaderT m) = L.ReaderT $ observing . m 349 eof = lift eof 350 token test mt = lift (token test mt) 351 tokens e ts = lift (tokens e ts) 352 takeWhileP l f = lift (takeWhileP l f) 353 takeWhile1P l f = lift (takeWhile1P l f) 354 takeP l n = lift (takeP l n) 355 getParserState = lift getParserState 356 updateParserState f = lift (updateParserState f) 357 358instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where 359 failure us ps = lift (failure us ps) 360 fancyFailure xs = lift (fancyFailure xs) 361 label n (L.WriterT m) = L.WriterT $ label n m 362 try (L.WriterT m) = L.WriterT $ try m 363 lookAhead (L.WriterT m) = L.WriterT $ 364 (,mempty) . fst <$> lookAhead m 365 notFollowedBy (L.WriterT m) = L.WriterT $ 366 (,mempty) <$> notFollowedBy (fst <$> m) 367 withRecovery r (L.WriterT m) = L.WriterT $ 368 withRecovery (L.runWriterT . r) m 369 observing (L.WriterT m) = L.WriterT $ 370 fixs mempty <$> observing m 371 eof = lift eof 372 token test mt = lift (token test mt) 373 tokens e ts = lift (tokens e ts) 374 takeWhileP l f = lift (takeWhileP l f) 375 takeWhile1P l f = lift (takeWhile1P l f) 376 takeP l n = lift (takeP l n) 377 getParserState = lift getParserState 378 updateParserState f = lift (updateParserState f) 379 380instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where 381 failure us ps = lift (failure us ps) 382 fancyFailure xs = lift (fancyFailure xs) 383 label n (S.WriterT m) = S.WriterT $ label n m 384 try (S.WriterT m) = S.WriterT $ try m 385 lookAhead (S.WriterT m) = S.WriterT $ 386 (,mempty) . fst <$> lookAhead m 387 notFollowedBy (S.WriterT m) = S.WriterT $ 388 (,mempty) <$> notFollowedBy (fst <$> m) 389 withRecovery r (S.WriterT m) = S.WriterT $ 390 withRecovery (S.runWriterT . r) m 391 observing (S.WriterT m) = S.WriterT $ 392 fixs mempty <$> observing m 393 eof = lift eof 394 token test mt = lift (token test mt) 395 tokens e ts = lift (tokens e ts) 396 takeWhileP l f = lift (takeWhileP l f) 397 takeWhile1P l f = lift (takeWhile1P l f) 398 takeP l n = lift (takeP l n) 399 getParserState = lift getParserState 400 updateParserState f = lift (updateParserState f) 401 402-- | @since 5.2.0 403 404instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where 405 failure us ps = lift (failure us ps) 406 fancyFailure xs = lift (fancyFailure xs) 407 label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) 408 try (L.RWST m) = L.RWST $ \r s -> try (m r s) 409 lookAhead (L.RWST m) = L.RWST $ \r s -> do 410 (x,_,_) <- lookAhead (m r s) 411 return (x,s,mempty) 412 notFollowedBy (L.RWST m) = L.RWST $ \r s -> do 413 notFollowedBy (void $ m r s) 414 return ((),s,mempty) 415 withRecovery n (L.RWST m) = L.RWST $ \r s -> 416 withRecovery (\e -> L.runRWST (n e) r s) (m r s) 417 observing (L.RWST m) = L.RWST $ \r s -> 418 fixs' s <$> observing (m r s) 419 eof = lift eof 420 token test mt = lift (token test mt) 421 tokens e ts = lift (tokens e ts) 422 takeWhileP l f = lift (takeWhileP l f) 423 takeWhile1P l f = lift (takeWhile1P l f) 424 takeP l n = lift (takeP l n) 425 getParserState = lift getParserState 426 updateParserState f = lift (updateParserState f) 427 428-- | @since 5.2.0 429 430instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where 431 failure us ps = lift (failure us ps) 432 fancyFailure xs = lift (fancyFailure xs) 433 label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) 434 try (S.RWST m) = S.RWST $ \r s -> try (m r s) 435 lookAhead (S.RWST m) = S.RWST $ \r s -> do 436 (x,_,_) <- lookAhead (m r s) 437 return (x,s,mempty) 438 notFollowedBy (S.RWST m) = S.RWST $ \r s -> do 439 notFollowedBy (void $ m r s) 440 return ((),s,mempty) 441 withRecovery n (S.RWST m) = S.RWST $ \r s -> 442 withRecovery (\e -> S.runRWST (n e) r s) (m r s) 443 observing (S.RWST m) = S.RWST $ \r s -> 444 fixs' s <$> observing (m r s) 445 eof = lift eof 446 token test mt = lift (token test mt) 447 tokens e ts = lift (tokens e ts) 448 takeWhileP l f = lift (takeWhileP l f) 449 takeWhile1P l f = lift (takeWhile1P l f) 450 takeP l n = lift (takeP l n) 451 getParserState = lift getParserState 452 updateParserState f = lift (updateParserState f) 453 454instance MonadParsec e s m => MonadParsec e s (IdentityT m) where 455 failure us ps = lift (failure us ps) 456 fancyFailure xs = lift (fancyFailure xs) 457 label n (IdentityT m) = IdentityT $ label n m 458 try = IdentityT . try . runIdentityT 459 lookAhead (IdentityT m) = IdentityT $ lookAhead m 460 notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m 461 withRecovery r (IdentityT m) = IdentityT $ 462 withRecovery (runIdentityT . r) m 463 observing (IdentityT m) = IdentityT $ observing m 464 eof = lift eof 465 token test mt = lift (token test mt) 466 tokens e ts = lift $ tokens e ts 467 takeWhileP l f = lift (takeWhileP l f) 468 takeWhile1P l f = lift (takeWhile1P l f) 469 takeP l n = lift (takeP l n) 470 getParserState = lift getParserState 471 updateParserState f = lift $ updateParserState f 472 473fixs :: s -> Either a (b, s) -> (Either a b, s) 474fixs s (Left a) = (Left a, s) 475fixs _ (Right (b, s)) = (Right b, s) 476{-# INLINE fixs #-} 477 478fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w) 479fixs' s (Left a) = (Left a, s, mempty) 480fixs' _ (Right (b,s,w)) = (Right b, s, w) 481{-# INLINE fixs' #-} 482