Simplify the type of the ‘token’ primitive

CHANGELOG.md

@@ -1,3 +1,11 @@
+## Megaparsec 7.0.0
+
+* Simplified the type of the `token` primitive. It now takes just a matching
+  function `Token s -> Maybe a` as the first argument and the collection of
+  expected items `Set (ErrorItem (Token s))` as the second argument. This
+  makes sense because the collection of expected items cannot depend on what
+  we see in the input stream.
+
 ## Megaparsec 6.4.0
 
 * Fix the `atEnd` parser. It now does not produce hints, so when you use it,

Text/Megaparsec.hs

@@ -771,28 +771,22 @@ class (Stream s, A.Alternative m, MonadPlus m)
 
   eof :: m ()
 
-  -- | The parser @'token' test mrep@ accepts a token @t@ with result @x@
-  -- when the function @test t@ returns @'Right' x@. @mrep@ may provide
-  -- representation of the token to report in error messages when input
-  -- stream in empty.
+  -- | The parser @'token' test exp@ accepts a token @t@ with result @x@
+  -- when the function @test t@ returns @'Just' x@. @exp@ specifies the
+  -- collection of expected items to report in error messages.
   --
   -- This is the most primitive combinator for accepting tokens. For
   -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as:
   --
-  -- > satisfy f = token testChar Nothing
+  -- > satisfy f = token testChar E.empty
   -- >   where
-  -- >     testChar x =
-  -- >       if f x
-  -- >         then Right x
-  -- >         else Left (pure (Tokens (x:|[])), Set.empty)
+  -- >     testChar x = if f x then Just x else Nothing
 
   token
-    :: (Token s -> Either ( Maybe (ErrorItem (Token s))
-                          , Set (ErrorItem (Token s)) ) a)
-       -- ^ Matching function for the token to parse, it allows to construct
-       -- arbitrary error message on failure as well; things in the tuple
-       -- are: unexpected item (if any) and expected items
-    -> Maybe (Token s) -- ^ Token to report when input stream is empty
+    :: (Token s -> Maybe a)
+       -- ^ Matching function for the token to parse
+    -> Set (ErrorItem (Token s))
+       -- ^ Expected items (in case of an error)
     -> m a
 
   -- | The parser @'tokens' test@ parses a chunk of input and returns it.
@@ -998,23 +992,22 @@ pEof = ParsecT $ \s@(State input (pos:|z) tp w) _ _ eok eerr ->
 {-# INLINE pEof #-}
 
 pToken :: forall e s m a. Stream s
-  => (Token s -> Either ( Maybe (ErrorItem (Token s))
-                        , Set (ErrorItem (Token s)) ) a)
-  -> Maybe (Token s)
+  => (Token s -> Maybe a)
+  -> Set (ErrorItem (Token s))
   -> ParsecT e s m a
-pToken test mtoken = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr ->
+pToken test ps = ParsecT $ \s@(State input (pos:|z) tp w) cok _ _ eerr ->
   case take1_ input of
     Nothing ->
       let us = pure EndOfInput
-          ps = maybe E.empty (E.singleton . Tokens . nes) mtoken
       in eerr (TrivialError (pos:|z) us ps) s
     Just (c,cs) ->
       case test c of
-        Left (us, ps) ->
+        Nothing ->
           let !apos = positionAt1 (Proxy :: Proxy s) pos c
+              us    = (Just . Tokens . nes) c
           in eerr (TrivialError (apos:|z) us ps)
                   (State input (apos:|z) tp w)
-        Right x ->
+        Just x ->
           let !npos = advance1 (Proxy :: Proxy s) w pos c
               newstate = State cs (npos:|z) (tp + 1) w
           in cok x newstate mempty

Text/Megaparsec/Char.hs

@@ -296,13 +296,10 @@ categoryName = \case
 -- > semicolon = char ';'
 
 char :: MonadParsec e s m => Token s -> m (Token s)
-char c = token testChar (Just c)
+char c = token testChar expected
   where
-    f x = Tokens (x:|[])
-    testChar x =
-      if x == c
-        then Right x
-        else Left (pure (f x), E.singleton (f c))
+    testChar x = if x == c then Just x else Nothing
+    expected   = E.singleton (Tokens (c:|[]))
 {-# INLINE char #-}
 
 -- | The same as 'char' but case-insensitive. This parser returns the
@@ -388,12 +385,9 @@ noneOf cs = satisfy (`notElem` cs)
 satisfy :: MonadParsec e s m
   => (Token s -> Bool) -- ^ Predicate to apply
   -> m (Token s)
-satisfy f = token testChar Nothing
+satisfy f = token testChar E.empty
   where
-    testChar x =
-      if f x
-        then Right x
-        else Left (pure (Tokens (x:|[])), E.empty)
+    testChar x = if f x then Just x else Nothing
 {-# INLINE satisfy #-}
 
 ----------------------------------------------------------------------------

tests/Text/MegaparsecSpec.hs

@@ -996,36 +996,33 @@ spec = do
             grs' eof s (`failsLeaving` s)
 
     describe "token" $ do
-      let f x = Tokens (nes x)
-          testChar a x =
-            if x == a
-              then Right x
-              else Left (pure (f x), E.singleton (f a))
+      let expected = E.singleton . Tokens . nes
+          testChar a x = if a == x then Just x else Nothing
       context "when supplied predicate is satisfied" $
         it "succeeds" $
-          property $ \a as mtok -> do
+          property $ \a as -> do
             let p :: MonadParsec Void String m => m Char
-                p = token (testChar a) mtok
+                p = token (testChar a) (expected a)
                 s = a : as
             grs  p s (`shouldParse` a)
             grs' p s (`succeedsLeaving` as)
       context "when supplied predicate is not satisfied" $
         it "signals correct parse error" $
-          property $ \a b as mtok -> a /= b ==> do
+          property $ \a b as -> a /= b ==> do
             let p :: MonadParsec Void String m => m Char
-                p = token (testChar b) mtok
+                p = token (testChar b) (expected b)
                 s = a : as
                 us = pure (Tokens $ nes a)
                 ps = E.singleton (Tokens $ nes b)
             grs  p s (`shouldFailWith` TrivialError posI us ps)
             grs' p s (`failsLeaving` s)
       context "when stream is empty" $
         it "signals correct parse error" $
-          property $ \a mtok -> do
+          property $ \a -> do
             let p :: MonadParsec Void String m => m Char
-                p = token (testChar a) mtok
+                p = token (testChar a) ps
                 us = pure EndOfInput
-                ps = maybe E.empty (E.singleton . Tokens . nes) mtok
+                ps = expected a
             grs p "" (`shouldFailWith` TrivialError posI us ps)
 
     describe "tokens" $ do
@@ -1800,13 +1797,13 @@ instance ShowErrorComponent Int where
 type CustomParser = Parsec Void [Span]
 
 pSpan :: Span -> CustomParser Span
-pSpan span = token testToken (Just span)
+pSpan span = token testToken expected
   where
-    f = Tokens . nes
     testToken x =
       if spanBody x == spanBody span
-        then Right span
-        else Left (pure (f x), E.singleton (f span))
+        then Just x
+        else Nothing
+    expected = (E.singleton . Tokens . nes) span
 
 incCoincidence :: State [Span] -> [Span] -> Gen (State [Span])
 incCoincidence st ts = do