From dd2386aafc6b23553dda3ae0bc97cba80cf4124a Mon Sep 17 00:00:00 2001 From: Mark Karpov Date: Mon, 21 Nov 2016 19:18:27 +0400 Subject: [PATCH] =?UTF-8?q?Add=20=E2=80=98MonadParsec=E2=80=99=20instance?= =?UTF-8?q?=20for=20=E2=80=98RWST=E2=80=99=20(#152)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- CHANGELOG.md | 4 + Text/Megaparsec/Prim.hs | 49 +++++++- tests/Test/Hspec/Megaparsec/AdHoc.hs | 16 +++ tests/Text/Megaparsec/PrimSpec.hs | 166 +++++++++++++++++++++++++++ 4 files changed, 234 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 48c20c7..a509b46 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/Text/Megaparsec/Prim.hs b/Text/Megaparsec/Prim.hs index d8011f1..18f013c 100644 --- a/Text/Megaparsec/Prim.hs +++ b/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 diff --git a/tests/Test/Hspec/Megaparsec/AdHoc.hs b/tests/Test/Hspec/Megaparsec/AdHoc.hs index 542935f..d16440f 100644 --- a/tests/Test/Hspec/Megaparsec/AdHoc.hs +++ b/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 diff --git a/tests/Text/Megaparsec/PrimSpec.hs b/tests/Text/Megaparsec/PrimSpec.hs index b80e447..238c910 100644 --- a/tests/Text/Megaparsec/PrimSpec.hs +++ b/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.