Merge pull request #759 from slotThe/parser/feature-parity

X.U.Parser: Achieve feature parity with ReadP

CHANGES.md

@@ -67,6 +67,13 @@
 
   - Added `findFile` as a shorthand to call `find-file`.
 
+* `XMonad.Util.Parser`
+
+  - Added the `gather`, `count`, `between`, `option`, `optionally`,
+    `skipMany`, `skipMany1`, `chainr`, `chainr1`, `chainl`, `chainl1`,
+    and `manyTill` functions, in order to achieve feature parity with
+    `Text.ParserCombinators.ReadP`.
+
 ### Other changes
 
 ## 0.17.1 (September 3, 2022)

XMonad/Prompt/OrgMode.hs

@@ -414,7 +414,7 @@ pInput inp = (`runParser` inp) . choice $
 
 -- | Parse a 'Priority'.
 pPriority :: Parser Priority
-pPriority = pLast (pure NoPriority) $
+pPriority = option NoPriority $
   " " *> skipSpaces *> choice
     [ "#" *> ("A" <|> "a") $> A
     , "#" *> ("B" <|> "b") $> B
@@ -423,7 +423,7 @@ pPriority = pLast (pure NoPriority) $
 
 -- | Try to parse a 'Time'.
 pTimeOfDay :: Parser (Maybe TimeOfDay)
-pTimeOfDay = pLast (pure Nothing) $
+pTimeOfDay = option Nothing $
   skipSpaces *> choice
     [ Just <$> (TimeOfDay <$> pHour <* string ":" <*> pMinute) -- HH:MM
     , Just <$> (TimeOfDay <$> pHour               <*> pure 0 ) -- HH
@@ -485,8 +485,3 @@ pNumBetween lo hi = do
   n <- num
   n <$ guard (n >= lo && n <= hi)
 
--- | A flipped version of '(<|>)'.  Useful when @p'@ is some complicated
--- expression that, for example, consumes spaces and @p@ does not want
--- to do that.
-pLast :: Parser a -> Parser a -> Parser a
-pLast p p' = p' <|> p

XMonad/Util/Parser.hs

@@ -36,6 +36,7 @@ module XMonad.Util.Parser (
   runParser,
 
   -- * Primitive Parsers
+  pfail,
   eof,
   num,
   char,
@@ -43,10 +44,17 @@ module XMonad.Util.Parser (
   skipSpaces,
   get,
   look,
+  gather,
 
   -- * Combining Parsers
   satisfy,
   choice,
+  count,
+  between,
+  option,
+  optionally,
+  skipMany,
+  skipMany1,
   many1,
   sepBy,
   sepBy1,
@@ -54,7 +62,11 @@ module XMonad.Util.Parser (
   endBy1,
   munch,
   munch1,
-  pfail
+  chainr,
+  chainr1,
+  chainl,
+  chainl1,
+  manyTill,
 ) where
 
 import XMonad.Prelude
@@ -123,18 +135,22 @@ instance Semigroup (Parser a) where
   -- produces any result at all, then right parser is not used.
   (<>) :: Parser a -> Parser a -> Parser a
   (<>) = coerce ((<++) @a)
+  {-# INLINE (<>) #-}
 
 instance Monoid (Parser a) where
   -- | A parser that always fails.
   mempty :: Parser a
   mempty = Parser empty
+  {-# INLINE mempty #-}
 
 instance Alternative Parser where
   empty :: Parser a
   empty = mempty
+  {-# INLINE empty #-}
 
   (<|>) :: Parser a -> Parser a -> Parser a
   (<|>) = (<>)
+  {-# INLINE (<|>) #-}
 
 -- | When @-XOverloadedStrings@ is on, treat a string @s@ as the parser
 -- @'string' s@, when appropriate.  This allows one to write things like
@@ -142,89 +158,199 @@ instance Alternative Parser where
 instance a ~ String => IsString (Parser a) where
   fromString :: String -> Parser a
   fromString = string
+  {-# INLINE fromString #-}
 
 -- | Run a parser on a given string.
 runParser :: Parser a -> String -> Maybe a
 runParser (Parser p) = fmap fst . listToMaybe . ReadP.readP_to_S p
+{-# INLINE runParser #-}
 
 -- | Always fails
 pfail :: Parser a
 pfail = empty
+{-# INLINE pfail #-}
 
 -- | Consume and return the next character.  Fails if there is no input
 -- left.
 get :: Parser Char
 get = coerce ReadP.get
+{-# INLINE get #-}
 
 -- | Look-ahead: return the part of the input that is left, without
 -- consuming it.
 look :: Parser String
 look = coerce ReadP.look
+{-# INLINE look #-}
+
+-- | Transform a parser into one that does the same, but in addition
+-- returns the exact characters read.
+--
+-- >>> runParser (         string "* " $> True) "* hi"
+-- Just True
+-- >>> runParser (gather $ string "* " $> True) "* hi"
+-- Just ("* ",True)
+gather :: forall a. Parser a -> Parser (String, a)
+gather = coerce (ReadP.gather @a)
+{-# INLINE gather #-}
 
 -- | Succeeds if and only if we are at the end of input.
 eof :: Parser ()
 eof = coerce ReadP.eof
+{-# INLINE eof #-}
 
--- | Parse an integral number number.
+-- | Parse an integral number.
 num :: (Read a, Integral a) => Parser a
 num = read <$> munch1 isDigit
-{-# SPECIALISE num :: Parser Word    #-}
+{-# INLINE num #-}
-{-# SPECIALISE num :: Parser Int     #-}
-{-# SPECIALISE num :: Parser Integer #-}
 
 -- | Parse and return the specified character.
 char :: Char -> Parser Char
 char = coerce ReadP.char
+{-# INLINE char #-}
 
 -- | Parse and return the specified string.
 string :: String -> Parser String
 string = coerce ReadP.string
+{-# INLINE string #-}
 
 -- | Skip all whitespace.
 skipSpaces :: Parser ()
 skipSpaces = coerce ReadP.skipSpaces
+{-# INLINE skipSpaces #-}
 
 -- | Consume and return the next character if it satisfies the specified
 -- predicate.
 satisfy :: (Char -> Bool) -> Parser Char
 satisfy = coerce ReadP.satisfy
+{-# INLINE satisfy #-}
 
 -- | Combine all parsers in the given list in a left-biased way.
 choice :: [Parser a] -> Parser a
 choice = foldl' (<>) mempty
+{-# INLINE choice #-}
+
+-- | @count n p@ parses @n@ occurrences of @p@ in sequence and returns a
+-- list of results.
+count :: Int -> Parser a -> Parser [a]
+count = replicateM
+{-# INLINE count #-}
+
+-- | @between open close p@ parses @open@, followed by @p@ and finally
+-- @close@.  Only the value of @p@ is returned.
+between :: Parser open -> Parser close -> Parser a -> Parser a
+between open close p = open *> p <* close
+{-# INLINE between #-}
+
+-- | @option def p@ will try to parse @p@ and, if it fails, simply
+-- return @def@ without consuming any input.
+option :: a -> Parser a -> Parser a
+option def p = p <|> pure def
+{-# INLINE option #-}
+
+-- | @optionally p@ optionally parses @p@ and always returns @()@.
+optionally :: Parser a -> Parser ()
+optionally p = void p <|> pure ()
+{-# INLINE optionally #-}
+
+-- | Like 'many', but discard the result.
+skipMany :: Parser a -> Parser ()
+skipMany = void . many
+{-# INLINE skipMany #-}
+
+-- | Like 'many1', but discard the result.
+skipMany1 :: Parser a -> Parser ()
+skipMany1 p = p *> skipMany p
+{-# INLINE skipMany1 #-}
 
 -- | Parse the first zero or more characters satisfying the predicate.
 -- Always succeeds; returns an empty string if the predicate returns
 -- @False@ on the first character of input.
 munch :: (Char -> Bool) -> Parser String
 munch = coerce ReadP.munch
+{-# INLINE munch #-}
 
 -- | Parse the first one or more characters satisfying the predicate.
 -- Fails if none, else succeeds exactly once having consumed all the
 -- characters.
 munch1 :: (Char -> Bool) -> Parser String
 munch1 = coerce ReadP.munch1
+{-# INLINE munch1 #-}
 
 -- | @endBy p sep@ parses zero or more occurrences of @p@, separated and
 -- ended by @sep@.
 endBy :: Parser a -> Parser sep -> Parser [a]
 endBy p sep = many (p <* sep)
+{-# INLINE endBy #-}
 
 -- | @endBy p sep@ parses one or more occurrences of @p@, separated and
 -- ended by @sep@.
 endBy1 :: Parser a -> Parser sep -> Parser [a]
 endBy1 p sep = many1 (p <* sep)
+{-# INLINE endBy1 #-}
 
 -- | Parse one or more occurrences of the given parser.
 many1 :: Parser a -> Parser [a]
-many1 p = liftA2 (:) p (many p)
+many1 = some
+{-# INLINE many1 #-}
 
 -- | @sepBy p sep@ parses zero or more occurrences of @p@, separated by
 -- @sep@.  Returns a list of values returned by @p@.
 sepBy :: Parser a -> Parser sep -> Parser [a]
 sepBy p sep = sepBy1 p sep <> pure []
+{-# INLINE sepBy #-}
 
 -- | @sepBy1 p sep@ parses one or more occurrences of @p@, separated by
 -- @sep@.  Returns a list of values returned by @p@.
 sepBy1 :: Parser a -> Parser sep -> Parser [a]
 sepBy1 p sep = liftA2 (:) p (many (sep *> p))
+{-# INLINE sepBy1 #-}
+
+-- | @chainr p op x@ parses zero or more occurrences of @p@, separated
+-- by @op@.  Returns a value produced by a /right/ associative
+-- application of all functions returned by @op@.  If there are no
+-- occurrences of @p@, @x@ is returned.
+chainr :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
+chainr p op x = option x (chainr1 p op)
+{-# INLINE chainr #-}
+
+-- | Like 'chainr', but parses one or more occurrences of @p@.
+chainr1 :: forall a. Parser a -> Parser (a -> a -> a) -> Parser a
+chainr1 p op = scan
+ where
+  scan :: Parser a
+  scan = p >>= rest
+
+  rest :: a -> Parser a
+  rest x = option x $ do f <- op
+                         f x <$> scan
+{-# INLINE chainr1 #-}
+
+-- | @chainl p op x@ parses zero or more occurrences of @p@, separated
+-- by @op@.  Returns a value produced by a /left/ associative
+-- application of all functions returned by @op@.  If there are no
+-- occurrences of @p@, @x@ is returned.
+chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
+chainl p op x = option x (chainl1 p op)
+{-# INLINE chainl #-}
+
+-- | Like 'chainl', but parses one or more occurrences of @p@.
+chainl1 :: forall a. Parser a -> Parser (a -> a -> a) -> Parser a
+chainl1 p op = scan
+ where
+  scan :: Parser a
+  scan = p >>= rest
+
+  rest :: a -> Parser a
+  rest x = option x $ do f <- op
+                         y <- p
+                         rest (f x y)
+{-# INLINE chainl1 #-}
+
+-- | @manyTill p end@ parses zero or more occurrences of @p@, until
+-- @end@ succeeds.  Returns a list of values returned by @p@.
+manyTill :: forall a end. Parser a -> Parser end -> Parser [a]
+manyTill p end = scan
+ where
+  scan :: Parser [a]
+  scan = end $> [] <|> liftA2 (:) p scan
+{-# INLINE manyTill #-}