Add ‘<&&>’ and ‘<||>’ combinators

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@.
 --

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.

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))

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'