Commit 53efdcd6 authored by code5hot's avatar code5hot Committed by Herbert Valerio Riedel

Add Monoid and Semigroup instances for `ParsecT`

`<>` 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
parent 4a211484
......@@ -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.*
......@@ -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)
......
module Features
( features
) where
import Test.Framework
import qualified Features.Feature80
features :: [Test]
features = [
Features.Feature80.main
]
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"
......@@ -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
]
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment