mirror of
https://github.com/mrkkrp/megaparsec.git
synced 2024-12-25 01:07:57 +03:00
Add ‘MonadParsec’ instance for ‘RWST’ (#152)
This commit is contained in:
Mark Karpov
GitHub
parent
38f5b36d46
commit
dd2386aafc
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user