Add ‘MonadParsec’ instance for ‘RWST’ (#152)

CHANGELOG.md

@@ -1,3 +1,7 @@
+## Megaparsec 5.2.0
+
+* Added `MonadParsec` instance for `RWST`.
+
 ## Megaparsec 5.1.2
 
 * Stopped using property tests with `dbg` helper to avoid flood of debugging

Text/Megaparsec/Prim.hs

@@ -82,6 +82,8 @@ import Prelude hiding (all)
 import Test.QuickCheck hiding (Result (..), label)
 import qualified Control.Applicative               as A
 import qualified Control.Monad.Fail                as Fail
+import qualified Control.Monad.RWS.Lazy            as L
+import qualified Control.Monad.RWS.Strict          as S
 import qualified Control.Monad.Trans.Reader        as L
 import qualified Control.Monad.Trans.State.Lazy    as L
 import qualified Control.Monad.Trans.State.Strict  as S
@@ -1124,7 +1126,7 @@ instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where
   getParserState             = lift getParserState
   updateParserState f        = lift (updateParserState f)
 
-instance MonadParsec e s m => MonadParsec e s (L.ReaderT st m) where
+instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where
   failure us ps xs            = lift (failure us ps xs)
   label n       (L.ReaderT m) = L.ReaderT $ label n . m
   try           (L.ReaderT m) = L.ReaderT $ try . m
@@ -1175,6 +1177,46 @@ instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where
   getParserState              = lift getParserState
   updateParserState f         = lift (updateParserState f)
 
+instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where
+  failure us ps xs            = lift (failure us ps xs)
+  label n          (L.RWST m) = L.RWST $ \r s -> label n (m r s)
+  try              (L.RWST m) = L.RWST $ \r s -> try (m r s)
+  lookAhead        (L.RWST m) = L.RWST $ \r s -> do
+    (x,_,_) <- lookAhead (m r s)
+    return (x,s,mempty)
+  notFollowedBy    (L.RWST m) = L.RWST $ \r s -> do
+    notFollowedBy (void $ m r s)
+    return ((),s,mempty)
+  withRecovery   n (L.RWST m) = L.RWST $ \r s ->
+    withRecovery (\e -> L.runRWST (n e) r s) (m r s)
+  observing        (L.RWST m) = L.RWST $ \r s ->
+    fixs' s <$> observing (m r s)
+  eof                         = lift eof
+  token test mt               = lift (token test mt)
+  tokens e ts                 = lift (tokens e ts)
+  getParserState              = lift getParserState
+  updateParserState f         = lift (updateParserState f)
+
+instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where
+  failure us ps xs            = lift (failure us ps xs)
+  label n          (S.RWST m) = S.RWST $ \r s -> label n (m r s)
+  try              (S.RWST m) = S.RWST $ \r s -> try (m r s)
+  lookAhead        (S.RWST m) = S.RWST $ \r s -> do
+    (x,_,_) <- lookAhead (m r s)
+    return (x,s,mempty)
+  notFollowedBy    (S.RWST m) = S.RWST $ \r s -> do
+    notFollowedBy (void $ m r s)
+    return ((),s,mempty)
+  withRecovery   n (S.RWST m) = S.RWST $ \r s ->
+    withRecovery (\e -> S.runRWST (n e) r s) (m r s)
+  observing        (S.RWST m) = S.RWST $ \r s ->
+    fixs' s <$> observing (m r s)
+  eof                         = lift eof
+  token test mt               = lift (token test mt)
+  tokens e ts                 = lift (tokens e ts)
+  getParserState              = lift getParserState
+  updateParserState f         = lift (updateParserState f)
+
 instance MonadParsec e s m => MonadParsec e s (IdentityT m) where
   failure us ps xs            = lift (failure us ps xs)
   label n       (IdentityT m) = IdentityT $ label n m
@@ -1195,6 +1237,11 @@ fixs s (Left a)       = (Left a, s)
 fixs _ (Right (b, s)) = (Right b, s)
 {-# INLINE fixs #-}
 
+fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w)
+fixs' s (Left a)        = (Left a, s, mempty)
+fixs' _ (Right (b,s,w)) = (Right b, s, w)
+{-# INLINE fixs' #-}
+
 ----------------------------------------------------------------------------
 -- Debugging
 

tests/Test/Hspec/Megaparsec/AdHoc.hs

@@ -56,6 +56,8 @@ import Test.Hspec.Megaparsec
 import Text.Megaparsec.Error
 import Text.Megaparsec.Pos
 import Text.Megaparsec.Prim
+import qualified Control.Monad.RWS.Lazy      as L
+import qualified Control.Monad.RWS.Strict    as S
 import qualified Control.Monad.State.Lazy    as L
 import qualified Control.Monad.State.Strict  as S
 import qualified Control.Monad.Writer.Lazy   as L
@@ -116,6 +118,8 @@ grs p s r = do
   r (prs (S.evalStateT p ()) s)
   r (prs (evalWriterTL p)    s)
   r (prs (evalWriterTS p)    s)
+  r (prs (evalRWSTL    p)    s)
+  r (prs (evalRWSTS    p)    s)
 
 -- | 'grs'' to 'grs' as 'prs'' to 'prs'.
 
@@ -133,12 +137,24 @@ grs' p s r = do
   r (prs' (S.evalStateT p ()) s)
   r (prs' (evalWriterTL p)    s)
   r (prs' (evalWriterTS p)    s)
+  r (prs' (evalRWSTL    p)    s)
+  r (prs' (evalRWSTS    p)    s)
 
 evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a
 evalWriterTL = liftM fst . L.runWriterT
 evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a
 evalWriterTS = liftM fst . S.runWriterT
 
+evalRWSTL :: Monad m => L.RWST () [Int] () m a -> m a
+evalRWSTL m = do
+  (a,_,_) <- L.runRWST m () ()
+  return a
+
+evalRWSTS :: Monad m => S.RWST () [Int] () m a -> m a
+evalRWSTS m = do
+  (a,_,_) <- S.runRWST m () ()
+  return a
+
 ----------------------------------------------------------------------------
 -- Working with source position
 

tests/Text/Megaparsec/PrimSpec.hs

@@ -61,6 +61,8 @@ import Text.Megaparsec.Error
 import Text.Megaparsec.Pos
 import Text.Megaparsec.Prim
 import Text.Megaparsec.String
+import qualified Control.Monad.RWS.Lazy      as L
+import qualified Control.Monad.RWS.Strict    as S
 import qualified Control.Monad.State.Lazy    as L
 import qualified Control.Monad.State.Strict  as S
 import qualified Control.Monad.Writer.Lazy   as L
@@ -1162,6 +1164,18 @@ spec = do
               return cs
         prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")
 
+    describe "lookAhead" $
+      it "discards what writer tells inside it" $
+        property $ \w -> do
+          let p = lookAhead (L.tell [w])
+          prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
+
+    describe "notFollowedBy" $
+      it "discards what writer tells inside it" $
+        property $ \w -> do
+          let p = notFollowedBy (L.tell [w] <* char 'a')
+          prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
+
     describe "observing" $ do
       context "when inner parser succeeds" $
         it "can affect log" $
@@ -1189,6 +1203,18 @@ spec = do
               return cs
         prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")
 
+    describe "lookAhead" $
+      it "discards what writer tells inside it" $
+        property $ \w -> do
+          let p = lookAhead (S.tell [w])
+          prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
+
+    describe "notFollowedBy" $
+      it "discards what writer tells inside it" $
+        property $ \w -> do
+          let p = notFollowedBy (S.tell [w] <* char 'a')
+          prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
+
     describe "observing" $ do
       context "when inner parser succeeds" $
         it "can affect log" $
@@ -1201,6 +1227,146 @@ spec = do
             let p = observing (S.tell (Sum n) <* empty)
             prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)
 
+  describe "MonadParsec instance of lazy RWST" $ do
+
+    describe "label" $
+      it "allows to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = label "a" ((,) <$> L.ask <*> L.get)
+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+
+    describe "try" $
+      it "allows to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = try ((,) <$> L.ask <*> L.get)
+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+
+    describe "lookAhead" $ do
+      it "allows to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = lookAhead ((,) <$> L.ask <*> L.get)
+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+      it "discards what writer tells inside it" $
+        property $ \w -> do
+          let p = lookAhead (L.tell [w])
+          prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`
+            ((), 0, mempty :: [Int])
+      it "does not allow to influence state outside it" $
+        property $ \s0 s1 -> (s0 /= s1) ==> do
+          let p = lookAhead (L.put s1)
+          prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`
+            ((), s0, mempty :: [Int])
+
+    describe "notFollowedBy" $ do
+      it "discards what writer tells inside it" $
+        property $ \w -> do
+          let p = notFollowedBy (L.tell [w] <* char 'a')
+          prs (L.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`
+            ((), 0, mempty :: [Int])
+      it "does not allow to influence state outside it" $
+        property $ \s0 s1 -> (s0 /= s1) ==> do
+          let p = notFollowedBy (L.put s1 <* char 'a')
+          prs (L.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`
+            ((), s0, mempty :: [Int])
+
+    describe "withRecovery" $ do
+      it "allows main parser to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = withRecovery (const empty) ((,) <$> L.ask <*> L.get)
+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+      it "allows recovering parser to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = withRecovery (\_ -> (,) <$> L.ask <*> L.get) empty
+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+
+    describe "observing" $ do
+      it "allows to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = observing ((,) <$> L.ask <*> L.get)
+          prs (L.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            (Right (r, s), s, mempty :: [Int])
+      context "when the inner parser fails" $
+        it "backtracks state" $
+          property $ \r s0 s1 -> (s0 /= s1) ==> do
+            let p = observing (L.put s1 <* empty)
+            prs (L.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`
+              (Left (err posI mempty), s0, mempty :: [Int])
+
+  describe "MonadParsec instance of strict RWST" $ do
+
+    describe "label" $
+      it "allows to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = label "a" ((,) <$> S.ask <*> S.get)
+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+
+    describe "try" $
+      it "allows to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = try ((,) <$> S.ask <*> S.get)
+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+
+    describe "lookAhead" $ do
+      it "allows to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = lookAhead ((,) <$> S.ask <*> S.get)
+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+      it "discards what writer tells inside it" $
+        property $ \w -> do
+          let p = lookAhead (S.tell [w])
+          prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`
+            ((), 0, mempty :: [Int])
+      it "does not allow to influence state outside it" $
+        property $ \s0 s1 -> (s0 /= s1) ==> do
+          let p = lookAhead (S.put s1)
+          prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`
+            ((), s0, mempty :: [Int])
+
+    describe "notFollowedBy" $ do
+      it "discards what writer tells inside it" $
+        property $ \w -> do
+          let p = notFollowedBy (S.tell [w] <* char 'a')
+          prs (S.runRWST p (0 :: Int) (0 :: Int)) "" `shouldParse`
+            ((), 0, mempty :: [Int])
+      it "does not allow to influence state outside it" $
+        property $ \s0 s1 -> (s0 /= s1) ==> do
+          let p = notFollowedBy (S.put s1 <* char 'a')
+          prs (S.runRWST p (0 :: Int) (s0 :: Int)) "" `shouldParse`
+            ((), s0, mempty :: [Int])
+
+    describe "withRecovery" $ do
+      it "allows main parser to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = withRecovery (const empty) ((,) <$> S.ask <*> S.get)
+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+      it "allows recovering parser to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = withRecovery (\_ -> (,) <$> S.ask <*> S.get) empty
+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            ((r, s), s, mempty :: [Int])
+
+    describe "observing" $ do
+      it "allows to access reader context and state inside it" $
+        property $ \r s -> do
+          let p = observing ((,) <$> S.ask <*> S.get)
+          prs (S.runRWST p (r :: Int) (s :: Int)) "" `shouldParse`
+            (Right (r, s), s, mempty :: [Int])
+      context "when the inner parser fails" $
+        it "backtracks state" $
+          property $ \r s0 s1 -> (s0 /= s1) ==> do
+            let p = observing (S.put s1 <* empty)
+            prs (S.runRWST p (r :: Int) (s0 :: Int)) "" `shouldParse`
+              (Left (err posI mempty), s0, mempty :: [Int])
+
   describe "dbg" $ do
     -- NOTE We don't test properties here to avoid flood of debugging output
     -- when the test runs.