Add Monoid and Semigroup instances for `ParsecT`
authorTristan Wibberley <tristan.wibberley@gmail.com>
Fri, 13 Oct 2017 03:07:46 +0000 (04:07 +0100)
committerHerbert Valerio Riedel <hvr@gnu.org>
Sat, 30 Dec 2017 11:25:43 +0000 (12:25 +0100)
`<>` does monoidal append of parse results instead of discarding
previous parser's results.

In case of `base < 4.9`, `semigroups` becomes a dependency

Closes #82

parsec.cabal
src/Text/Parsec/Prim.hs
test/Features.hs [new file with mode: 0644]
test/Features/Feature80.hs [new file with mode: 0644]
test/Main.hs

index 12f5f61..4f3c8e7 100644 (file)
@@ -79,8 +79,9 @@ library
     if impl(ghc >= 8.0)
         ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
     else
-        -- provide/emulate `Control.Monad.Fail` API for pre-GHC8
-        build-depends: fail == 4.9.*
+        -- provide/emulate `Control.Monad.Fail` and `Semigroup` API for pre-GHC8
+        build-depends: fail == 4.9.*, semigroups == 0.18.*
+
 
 test-suite parsec
     type: exitcode-stdio-1.0
@@ -93,10 +94,13 @@ test-suite parsec
         Bugs.Bug6
         Bugs.Bug9
         Bugs.Bug35
+        Features
+        Features.Feature80
         Util
 
     build-depends:
         base,
+        mtl,
         parsec,
         -- dependencies whose version bounds are not inherited via lib:parsec
         HUnit                >= 1.2 && < 1.4,
@@ -108,3 +112,5 @@ test-suite parsec
     ghc-options: -Wall
     if impl(ghc >= 8.0)
         ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
+    else
+        build-depends: semigroups == 0.18.*
index b1044d8..b1cb3cb 100644 (file)
@@ -80,6 +80,7 @@ module Text.Parsec.Prim
     ) where
 
 
+import Prelude hiding (sequence)
 import qualified Data.ByteString.Lazy.Char8 as CL
 import qualified Data.ByteString.Char8 as C
 
@@ -88,10 +89,18 @@ import Data.Typeable ( Typeable )
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as TextL
 
-import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
-import Control.Monad()
+-- To define Monoid instance
+import qualified Data.List.NonEmpty as NonEmpty ( fromList )
+import Data.List ( genericReplicate )
+import Data.Traversable (sequence)
+import qualified Data.Functor as Functor ( Functor(..), fmap )
+import qualified Data.Semigroup as Semigroup ( Semigroup(..) )
+import qualified Data.Monoid as Monoid ( Monoid(..) )
+
+import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..), liftA2 )
+import Control.Monad hiding (sequence)
 import Control.Monad.Trans
-import Control.Monad.Identity
+import Control.Monad.Identity hiding (sequence)
 import qualified Control.Monad.Fail as Fail
 
 import Control.Monad.Reader.Class
@@ -185,6 +194,42 @@ data State s u = State {
     }
     deriving ( Typeable )
 
+-- | The 'Semigroup' instance for 'ParsecT' is used to append the result
+--  of several parsers, for example:
+--
+--  @
+--  (many $ char 'a') <> (many $ char 'b')
+--  @
+--
+--  The above will parse a string like @"aabbb"@ and return a successful
+--  parse result @"aabbb"@. Compare against the below which will
+--  produce a result of @"bbb"@ for the same input:
+--
+--  @
+--  (many $ char 'a') >> (many $ char 'b')
+--  (many $ char 'a') *> (many $ char 'b')
+--  @
+--
+instance Semigroup.Semigroup a => Semigroup.Semigroup (ParsecT s u m a) where
+    -- | Combines two parsers like '*>', '>>' and @do {...;...}@
+    --  /but/ also combines their results with (<>) instead of
+    --  discarding the first.
+    (<>)     = Applicative.liftA2 (Semigroup.<>)
+    sconcat  = (fmap Semigroup.sconcat) . sequence
+    stimes b = Semigroup.sconcat . NonEmpty.fromList . (genericReplicate b)
+
+-- | The 'Monoid' instance for 'ParsecT' is used for the same purposes as
+-- the 'Semigroup' instance.
+instance ( Monoid.Monoid a
+         , Semigroup.Semigroup (ParsecT s u m a)
+         ) => Monoid.Monoid (ParsecT s u m a) where
+    -- | A parser that always succeeds, consumes no input, and
+    --  returns the underlying 'Monoid''s 'mempty' value
+    mempty = Applicative.pure Monoid.mempty
+
+    -- | See 'ParsecT''s 'Semigroup.<>' implementation
+    mappend = (Semigroup.<>)
+
 instance Functor Consumed where
     fmap f (Consumed x) = Consumed (f x)
     fmap f (Empty x)    = Empty (f x)
diff --git a/test/Features.hs b/test/Features.hs
new file mode 100644 (file)
index 0000000..24e7f47
--- /dev/null
@@ -0,0 +1,12 @@
+module Features
+       ( features
+       ) where
+
+import Test.Framework
+
+import qualified Features.Feature80
+
+features :: [Test]
+features = [
+             Features.Feature80.main
+           ]
diff --git a/test/Features/Feature80.hs b/test/Features/Feature80.hs
new file mode 100644 (file)
index 0000000..b92db42
--- /dev/null
@@ -0,0 +1,51 @@
+
+module Features.Feature80
+       ( main
+       ) where
+
+import Test.HUnit hiding ( Test )
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Data.List.NonEmpty
+import Data.Semigroup
+import Control.Monad.Identity
+import Control.Applicative (pure)
+
+import Text.Parsec
+
+main :: Test
+main =
+  testCase "Monoid instance (#80)" $ do
+    parseString (as <> bs) "aabbb" @?= "aabbb"
+    parseString (mempty <> as) "aabbb" @?= "aa"
+    parseString (as <> mempty) "aabbb" @?= "aa"
+    parseString (sconcat $ fromList [as, mempty, bs]) "aabbb" @?= "aabbb"
+    parseString (mconcat [as, mempty, bs]) "aabbb" @?= "aabbb"
+    parseString (mempty :: ParsecT String () Identity String) "aabbb" @?= ""
+    parseString (stimes 2 str_a) "aabbb" @?= "aa"
+    parseFail   (stimes 3 str_a) "aabbb" @?= "no parse"
+    parseString ((one ch_a) <> (one ch_a) <> bs) "aabbb" @?= "aabbb"
+
+ where
+   one = fmap pure
+
+   as :: ParsecT String () Identity String
+   as = many $ char 'a'
+   bs :: ParsecT String () Identity String
+   bs = many $ char 'b'
+   ch_a :: ParsecT String () Identity Char
+   ch_a = char 'a'
+   str_a :: ParsecT String () Identity String
+   str_a = string "a"
+
+   parseString :: ParsecT String () Identity String -> String -> String
+   parseString p input =
+      case parse p "Example" input of
+        Left{} -> error "Parse failure"
+        Right str -> str
+
+   parseFail :: ParsecT String () Identity String -> String -> String
+   parseFail p input =
+      case parse p "Example" input of
+        Left{} -> "no parse"
+        Right _ -> error "Parsed but shouldn't" 
index 77584e9..76550f3 100644 (file)
@@ -2,9 +2,11 @@
 import Test.Framework
 
 import Bugs ( bugs )
+import Features ( features )
 
 main :: IO ()
 main = do
   defaultMain
     [ testGroup "Bugs" bugs
-    ]
\ No newline at end of file
+    , testGroup "Features" features
+    ]