From 7db0c61e0d61eb308d5787ceba4def0efcb5e1fe Mon Sep 17 00:00:00 2001 From: Jon Purdy Date: Sun, 30 Nov 2025 12:21:31 -0800 Subject: [PATCH] =?UTF-8?q?Add=20=E2=80=98<&&>=E2=80=99=20and=20=E2=80=98=E2=80=99=20combinators?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit These are often useful for writing lexing predicates (`Char -> Bool`), as well as for writing verifiers (`Parser Bool`). I always find myself rewriting them, and this package seems like a good home for them. This adds both applicative and monadic forms, and a bit of documentation to clarify their different short-circuiting behavior. Since the possibility space for `Bool` is so small, the included tests are exhaustive unit tests, instead of using random sampling. --- Control/Applicative/Combinators.hs | 62 +++++++++++++++++++ Control/Monad/Combinators.hs | 38 ++++++++++++ .../Control/Applicative/CombinatorsSpec.hs | 37 +++++++++++ .../tests/Control/Monad/CombinatorsSpec.hs | 40 ++++++++++++ 4 files changed, 177 insertions(+) diff --git a/Control/Applicative/Combinators.hs b/Control/Applicative/Combinators.hs index e253240..8d0da70 100644 --- a/Control/Applicative/Combinators.hs +++ b/Control/Applicative/Combinators.hs @@ -44,6 +44,26 @@ -- backtrack in order for the alternative branch of parsing to be tried. -- Thus it is the responsibility of the programmer to wrap more complex, -- composite parsers in @try@ to achieve correct behavior. +-- +-- === Short-circuiting #short-circuiting# +-- +-- The lifted logical operators '<&&>' and '<||>' +-- are lazy in evaluating /results/ (1, 2) assuming that @pure@ is lazy (3). +-- However, note that these combinators are strict in executing /effects/: +-- @p '<&&>' q@ and @p '<||>' q@ always run both @p@ and @q@ (4, 5). +-- +-- 1. @pure False '<&&>' pure undefined@ = @pure False@ +-- 2. @pure True '<||>' pure undefined@ = @pure True@ +-- 3. @'Control.Monad.void' (pure undefined)@ = @pure ()@ +-- 4. @(False \<$ p) '<&&>' (True \<$ q)@ = @False \<$ (p *> q)@ +-- 5. @(True \<$ p) '<||>' (False \<$ q)@ = @True \<$ (p *> q)@ +-- +-- While this makes no difference when combining pure predicates, +-- it may be significant for correctness or performance +-- when combining actions in parsers or other monads. +-- If you want short-circuiting of effects for these operators, +-- use their counterparts in "Control.Monad.Combinators" instead. +-- module Control.Applicative.Combinators ( -- * Re-exports from "Control.Applicative" (<|>), @@ -58,6 +78,8 @@ module Control.Applicative.Combinators -- $empty -- * Original combinators + (<&&>), + (<||>), between, choice, count, @@ -127,6 +149,46 @@ import Control.Monad (replicateM, replicateM_) ---------------------------------------------------------------------------- -- Original combinators +-- | @p '<&&>' q@ parses @p@ followed by @q@ +-- and then combines their results with logical AND. +-- It always parses both @p@ and @q@, even if @p@ returns @False@; +-- see "Control.Applicative.Combinators#short-circuiting". +-- +-- This may also be used to combine predicates: +-- +-- @ +-- isBaseSixDigit :: Char -> Bool +-- isBaseSixDigit = (>= \'0\') '<&&>' (\< \'6\') +-- @ +-- +-- @\<&&>@ has the same precedence as '&&'. +-- +-- See also: '<||>'. +(<&&>) :: (Applicative m) => m Bool -> m Bool -> m Bool +(<&&>) = liftA2 (&&) +infixr 3 <&&> +{-# INLINE (<&&>) #-} + +-- | @p '<||>' q@ parses @p@ followed by @q@ +-- and then combines their results with logical OR. +-- It always parses both @p@ and @q@, even if @p@ returns @True@; +-- see "Control.Applicative.Combinators#short-circuiting". +-- +-- This may also be used to combine predicates: +-- +-- @ +-- isAsciiLetter :: Char -> Bool +-- isAsciiLetter = 'Data.Char.isAsciiUpper' '<||>' 'Data.Char.isAsciiLower' +-- @ +-- +-- @\<||>@ has the same precedence as '||'. +-- +-- See also: '<&&>'. +(<||>) :: (Applicative m) => m Bool -> m Bool -> m Bool +(<||>) = liftA2 (||) +infixr 2 <||> +{-# INLINE (<||>) #-} + -- | @'between' open close p@ parses @open@, followed by @p@ and @close@. -- Returns the value returned by @p@. -- diff --git a/Control/Monad/Combinators.hs b/Control/Monad/Combinators.hs index a490abb..55bf26a 100644 --- a/Control/Monad/Combinators.hs +++ b/Control/Monad/Combinators.hs @@ -27,6 +27,8 @@ module Control.Monad.Combinators -- $empty -- * Original combinators + (<&&>), + (<||>), C.between, C.choice, count, @@ -82,6 +84,42 @@ import Control.Monad ---------------------------------------------------------------------------- -- Original combinators +-- | @p '<&&>' q@ implements a +-- [short-circuiting]("Control.Applicative.Combinators#short-circuiting") +-- logical AND of @p@ and @q@, equivalent to: +-- +-- - @p@, if @p@ succeeds and returns @False@ +-- - @p *> q@, if @p@ succeeds and returns @True@ +-- - 'empty', if either @p@ or @q@ fails +-- +-- @\<&&>@ has the same precedence as '&&'. +-- +-- See also: '<||>'. +(<&&>) :: (Monad m) => m Bool -> m Bool -> m Bool +p <&&> q = do + x <- p + if x then q else pure False +infixr 3 <&&> +{-# INLINE (<&&>) #-} + +-- | @p '<||>' q@ implements a +-- [short-circuiting]("Control.Applicative.Combinators#short-circuiting") +-- logical OR of @p@ and @q@, equivalent to: +-- +-- - @p@, if @p@ succeeds and returns @True@ +-- - @p *> q@, if @p@ succeeds and returns @False@ +-- - 'empty', if either @p@ or @q@ fails +-- +-- @\<||>@ has the same precedence as '||'. +-- +-- See also: '<&&>'. +(<||>) :: (Monad m) => m Bool -> m Bool -> m Bool +p <||> q = do + x <- p + if x then pure True else q +infixr 2 <||> +{-# INLINE (<||>) #-} + -- | @'count' n p@ parses @n@ occurrences of @p@. If @n@ is smaller or equal -- to zero, the parser equals to @'return' []@. Returns a list of @n@ -- values. diff --git a/parser-combinators-tests/tests/Control/Applicative/CombinatorsSpec.hs b/parser-combinators-tests/tests/Control/Applicative/CombinatorsSpec.hs index 6059fdb..446a794 100644 --- a/parser-combinators-tests/tests/Control/Applicative/CombinatorsSpec.hs +++ b/parser-combinators-tests/tests/Control/Applicative/CombinatorsSpec.hs @@ -14,6 +14,43 @@ import Text.Megaparsec.Char spec :: Spec spec = do + + describe "logical" $ do + let + b = undefined <$ char 'u' <|> False <$ char 'f' <|> True <$ char 't' + ux = utok 'x' + eb = etok 'u' <> etok 'f' <> etok 't' + + describe "<&&>" $ do + let p = b <&&> b + it "works" $ do + prs_ p "t" `shouldFailWith` err 1 (eb <> ueof) + prs_ p "tf" `shouldParse` False + prs_ p "tt" `shouldParse` True + prs_ p "tx" `shouldFailWith` err 1 (eb <> ux) + prs_ p "x" `shouldFailWith` err 0 (eb <> ux) + it "does not short-circuit" $ do + prs_ p "f" `shouldFailWith` err 1 (eb <> ueof) + prs_ p "ff" `shouldParse` False + prs_ p "ft" `shouldParse` False + prs_ p "fu" `shouldParse` False + prs_ p "fx" `shouldFailWith` err 1 (eb <> ux) + + describe "<||>" $ do + let p = b <||> b + it "works" $ do + prs_ p "f" `shouldFailWith` err 1 (eb <> ueof) + prs_ p "ff" `shouldParse` False + prs_ p "ft" `shouldParse` True + prs_ p "fx" `shouldFailWith` err 1 (eb <> ux) + prs_ p "x" `shouldFailWith` err 0 (eb <> ux) + it "does not short-circuit" $ do + prs_ p "t" `shouldFailWith` err 1 (eb <> ueof) + prs_ p "tf" `shouldParse` True + prs_ p "tt" `shouldParse` True + prs_ p "tu" `shouldParse` True + prs_ p "tx" `shouldFailWith` err 1 (eb <> ux) + describe "between" $ it "works" . property $ \pre c n' post -> do let p = between (string pre) (string post) (many (char c)) diff --git a/parser-combinators-tests/tests/Control/Monad/CombinatorsSpec.hs b/parser-combinators-tests/tests/Control/Monad/CombinatorsSpec.hs index 49296a5..9a3f3a8 100644 --- a/parser-combinators-tests/tests/Control/Monad/CombinatorsSpec.hs +++ b/parser-combinators-tests/tests/Control/Monad/CombinatorsSpec.hs @@ -13,6 +13,46 @@ import Text.Megaparsec.Char spec :: Spec spec = do + + describe "logical" $ do + let + b = undefined <$ char 'u' <|> False <$ char 'f' <|> True <$ char 't' + eb = etok 'u' <> etok 'f' <> etok 't' + uf = utok 'f' + ut = utok 't' + uu = utok 'u' + ux = utok 'x' + + describe "<&&>" $ do + let p = b <&&> b + it "works" $ do + prs_ p "t" `shouldFailWith` err 1 (eb <> ueof) + prs_ p "tf" `shouldParse` False + prs_ p "tt" `shouldParse` True + prs_ p "tx" `shouldFailWith` err 1 (eb <> ux) + prs_ p "x" `shouldFailWith` err 0 (eb <> ux) + it "short-circuits" $ do + prs_ p "f" `shouldParse` False + prs_ p "ff" `shouldFailWith` err 1 (eeof <> uf) + prs_ p "ft" `shouldFailWith` err 1 (eeof <> ut) + prs_ p "fu" `shouldFailWith` err 1 (eeof <> uu) + prs_ p "fx" `shouldFailWith` err 1 (eeof <> ux) + + describe "<||>" $ do + let p = b <||> b + it "works" $ do + prs_ p "f" `shouldFailWith` err 1 (eb <> ueof) + prs_ p "ff" `shouldParse` False + prs_ p "ft" `shouldParse` True + prs_ p "fx" `shouldFailWith` err 1 (eb <> ux) + prs_ p "x" `shouldFailWith` err 0 (eb <> ux) + it "short-circuits" $ do + prs_ p "t" `shouldParse` True + prs_ p "tf" `shouldFailWith` err 1 (eeof <> uf) + prs_ p "tt" `shouldFailWith` err 1 (eeof <> ut) + prs_ p "tu" `shouldFailWith` err 1 (eeof <> uu) + prs_ p "tx" `shouldFailWith` err 1 (eeof <> ux) + describe "count" $ do it "works" . property $ \n x' -> do let x = getNonNegative x'