parsers 0.10.3 → 0.12.12
raw patch · 16 files changed
Files
- .hlint.yaml +7/−0
- .travis.yml +0/−28
- CHANGELOG.markdown +159/−0
- README.markdown +21/−0
- Setup.hs +2/−0
- Setup.lhs +0/−44
- parsers.cabal +68/−31
- src/Text/Parser/Char.hs +29/−18
- src/Text/Parser/Combinators.hs +115/−58
- src/Text/Parser/Expression.hs +27/−5
- src/Text/Parser/LookAhead.hs +26/−10
- src/Text/Parser/Permutation.hs +8/−6
- src/Text/Parser/Token.hs +221/−42
- src/Text/Parser/Token/Style.hs +11/−8
- tests/QuickCheck.hs +107/−0
- tests/doctests.hs +0/−30
+ .hlint.yaml view
@@ -0,0 +1,7 @@+- arguments: [-XCPP, --cpp-define=HLINT, --cpp-ansi]++- ignore: {name: Reduce duplication}+- ignore: {name: Use String}+# Needed for backwards compatibility with old versions of base, where+# replicateM had a Monad constraint instead of an Applicative one.+- ignore: {name: Use replicateM, within: [Text.Parser.Combinators]}
− .travis.yml
@@ -1,28 +0,0 @@-language: haskell-before_install:- # Uncomment whenever hackage is down.- # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update-- # Try installing some of the build-deps with apt-get for speed.- - travis/cabal-apt-install --only-dependencies --force-reinstall $mode-- - sudo apt-get -q -y install hlint || cabal install hlint--install:- - cabal configure -flib-Werror $mode- - cabal build--script:- - $script- - hlint src --cpp-define HLINT--notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313parsers\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"--env:- - mode="--enable-tests" script="cabal test"
+ CHANGELOG.markdown view
@@ -0,0 +1,159 @@+0.12.12 [2024.10.26]+--------------------+* Support building with `text-2.1.2`.+* Drop support for pre-8.0 versions of GHC.++0.12.11 [2022.05.07]+--------------------+* Allow building with `transformers-0.6.*` and `mtl-2.3.*`.++0.12.10 [2019.05.02]+--------------------+* Make the `parsec` and `attoparsec` dependencies optional with the use of+ `Cabal` flags of the same names.++0.12.9 [2018.07.04]+-------------------+* Add instances for the `Get` type from `binary`.+* Add a `surroundedBy` function, as a shorthand for `between bra ket` when+ `bra` and `ket` are the same.++0.12.8+------+* Remove the `doctest` test suite, as there are no actual doctests anywhere+ in `parsers`.++0.12.7+------+* Add `sepByNonEmpty`, `sepEndByNonEmpty`, and `endByNonEmpty` to+ `Text.Parser.Combinators`+* Fix sporadic `QuickCheck` test suite failures++0.12.6+------+* Add a library dependency in the `doctests` test suite++0.12.5+------+* Allow building with GHC 8.2+* Add `mtl` instances for `Unspaced`, `Unhighlighted`, and `Unlined`+* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build+ with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and+ sandboxes.++0.12.4+------+* Allow `transformers` 0.5++0.12.3+------+* Build without warnings on GHC 7.10+* Add `LookAheadParsing` instance for `attoparsec`+* Documentation fixes+* Fix out-of-bounds error in numeric escapes+* Depend on `base-orphans` for `Applicative ReadP` on old `base`++0.12.2+------+* Added parsers for `scientific`, so we can parse decimal places without losing precision.++0.12.1+----+* Fixed the fixed behavior of `notFollowedBy`, which was showing internal state. This had led to unnecessary constraints on internal state that are now removed.++0.12+------+* Fixed the behavior of `notFollowedBy`. This necessitated removing the default implementation, and therefore required a major version bump.++0.11.0.2+--------+* Allow `attoparsec` 0.12++0.11+----+* Mikhail Vorozhtsov refactored `attoparsec` to permit `parsers` instances. Instances added.++0.10.3+------+* Compatibility with ghc 7.8 roles++0.10.2+------+* Documentation fixes++0.10.1.2+--------+* Updated to work with `text` 1.0++0.10.1.1+--------+* 0.10.1 accidentally prevented the orphan instances for ReadP from compiling. Fxed.++0.10.1+------+* Fixed an issue with the expression parser, where it didn't `try` hard enough.+* Added `satisfyRange`+* Fixed a longstanding issue with the char escapes that we inherited from parsec, where ^A and the like were returning 0 not 1.++0.10+----+* Added proper upper bounds for PVP compliance+* Switched to an applicative expression parser++0.9+---+* `instance MonadTrans Unlined`++0.8.3+-----+* Fixed a _major_ performance regression in Text.Parser.Expression++0.8.2+-----+* Added `scalaCommentStyle`.++0.8.1+-----+* Text.Parser.Token.* is now Trustworthy++0.8+---+* Removed the need for `textLiteral`, `textLiteral'` and `identText` by using `fromString`. Use `stringLiteral`, `stringLiteral'`, and `ident` instead respectively.++0.7.1+-----+* Added support for `Text`-based parsing.++0.7+---+* Added `Unlined` to support parsing solely within a line+* Simplified `TokenParsing` instances++0.6+---+* Disallowed nested comments in 'javaCommentStyle'+* More derived instances++0.5.2+-----+* Bugfix in `commaSep1`.++0.5.1+-----+* Taught zeroNumFloat about `0.`.+* Bugfix in `buildExpressionParser`.++0.5+---+* Split out `LookAheadParsing` since it wasn't used by other combinators here and isn't supported by `attoparsec`.++0.4.1+-----+* Added `token` to `TokenParsing`.++0.4+-----+* Updated build system+* Converted various style accessors to lenses and traversals+* More aggressive inlining+* Added CHANGELOG
+ README.markdown view
@@ -0,0 +1,21 @@+parsers+=======++[](https://hackage.haskell.org/package/parsers) [](https://github.com/ekmett/parsers/actions?query=workflow%3AHaskell-CI)++Goals+-----++This library provides convenient combinators for working with and building parsing combinator libraries.++Given a few simple instances, you get access to a large number of canned definitions.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
− Setup.lhs
@@ -1,44 +0,0 @@-#!/usr/bin/runhaskell-\begin{code}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )-import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )-import Distribution.Verbosity ( Verbosity )-import System.FilePath ( (</>) )--main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- }--generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule verbosity pkg lbi = do- let dir = autogenModulesDir lbi- createDirectoryIfMissingVerbose verbosity True dir- withLibLBI pkg lbi $ \_ libcfg -> do- withTestLBI pkg lbi $ \suite suitecfg -> do- rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines- [ "module Build_" ++ testName suite ++ " where"- , "deps :: [String]"- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))- ]- where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)--testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys--\end{code}
parsers.cabal view
@@ -1,6 +1,6 @@ name: parsers category: Text, Parsing-version: 0.10.3+version: 0.12.12 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -11,20 +11,50 @@ bug-reports: http://github.com/ekmett/parsers/issues copyright: Copyright (C) 2010-2013 Edward A. Kmett synopsis: Parsing combinators-description: Parsing combinators-build-type: Custom+description:+ This library provides convenient combinators for working with and building parsing combinator libraries.+ .+ Given a few simple instances, e.g. for the class 'Text.Parser.Combinators.Parsing' in "Text.Parser.Combinators.Parsing" you+ get access to a large number of canned definitions. Instances exist for the parsers provided by @parsec@,+ @attoparsec@ and base’s "Text.Read".+build-type: Simple+tested-with: GHC==8.0.2+ , GHC==8.2.2+ , GHC==8.4.4+ , GHC==8.6.5+ , GHC==8.8.4+ , GHC==8.10.7+ , GHC==9.0.2+ , GHC==9.2.8+ , GHC==9.4.8+ , GHC==9.6.6+ , GHC==9.8.2+ , GHC==9.10.1 -extra-source-files: .travis.yml+extra-source-files:+ .hlint.yaml+ CHANGELOG.markdown+ README.markdown source-repository head type: git location: git://github.com/ekmett/parsers.git -flag lib-Werror- description: Treat warnings as errors when building.- manual: True- default: False+flag binary+ default: True+ description:+ You can disable the use of the `binary` package using `-f-binary`. +flag parsec+ default: True+ description:+ You can disable the use of the `parsec` package using `-f-parsec`.++flag attoparsec+ default: True+ description:+ You can disable the use of the `attoparsec` package using `-f-attoparsec`.+ library default-language: Haskell2010 exposed-modules:@@ -39,34 +69,41 @@ hs-source-dirs: src - if flag(lib-Werror)- ghc-options: -Wall- else- ghc-options: -Wall-- ghc-options: -O2+ ghc-options: -Wall -Wno-wrong-do-bind -Wmonomorphism-restriction -Wincomplete-record-updates -Widentities -Wincomplete-uni-patterns -Wno-trustworthy-safe build-depends:- base >= 4 && < 5,- charset >= 0.3 && < 1,- containers >= 0.4 && < 0.6,- parsec >= 3.1 && < 3.2,- text >= 0.10 && < 1.2,- transformers >= 0.2 && < 0.4,- unordered-containers >= 0.2 && < 0.3+ base >= 4.9 && < 5,+ charset >= 0.3 && < 1,+ containers >= 0.4 && < 0.8,+ text >= 0.10 && < 2.2,+ transformers >= 0.2 && < 0.7,+ mtl >= 2.0.1 && < 2.4,+ scientific >= 0.3 && < 0.4,+ unordered-containers >= 0.2 && < 0.3 --- Verify the results of the examples-test-suite doctests+ if flag(binary)+ build-depends: binary >= 0.7.2 && < 1+ if flag(parsec)+ build-depends: parsec >= 3.1 && < 3.2+ if flag(attoparsec)+ build-depends: attoparsec >= 0.12.1.4 && < 0.15+ if impl(ghc < 8.0)+ build-depends: semigroups >= 0.12 && < 1++test-suite quickcheck type: exitcode-stdio-1.0- main-is: doctests.hs+ main-is: QuickCheck.hs default-language: Haskell2010 build-depends:- base,- containers,- directory >= 1.0,- doctest >= 0.9.1,- filepath+ base == 4.*,+ bytestring,+ parsers,+ QuickCheck,+ quickcheck-instances ghc-options: -Wall -threaded- if impl(ghc<7.6.1)- ghc-options: -Werror hs-source-dirs: tests++ if flag(parsec)+ build-depends: parsec >= 3+ if flag(attoparsec)+ build-depends: attoparsec
src/Text/Parser/Char.hs view
@@ -1,14 +1,10 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704-#define USE_DEFAULT_SIGNATURES-#endif--#ifdef USE_DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures, TypeFamilies #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Char@@ -45,7 +41,6 @@ , CharParsing(..) ) where -import Control.Applicative import Control.Monad.Trans.Class import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict@@ -61,12 +56,20 @@ import qualified Data.CharSet as CharSet import Data.Foldable import qualified Data.IntSet as IntSet-import Data.Monoid-import Data.Text+import qualified Data.Text as Text+import Data.Text (Text) import qualified Text.ParserCombinators.ReadP as ReadP-import qualified Text.Parsec as Parsec import Text.Parser.Combinators +#ifdef MIN_VERSION_parsec+import qualified Text.Parsec as Parsec+#endif++#ifdef MIN_VERSION_attoparsec+import qualified Data.Attoparsec.Types as Att+import qualified Data.Attoparsec.Combinator as Att+#endif+ -- | @oneOf cs@ succeeds if the current character is in the supplied -- list of characters @cs@. Returns the parsed character. See also -- 'satisfy'.@@ -78,7 +81,7 @@ {-# ANN oneOf "HLint: ignore Use String" #-} -- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current--- character /not/ in the supplied list of characters @cs@. Returns the+-- character is /not/ in the supplied list of characters @cs@. Returns the -- parsed character. -- -- > consonant = noneOf "aeiou"@@ -98,7 +101,7 @@ {-# INLINE oneOfSet #-} -- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current--- character /not/ in the supplied list of characters @cs@. Returns the+-- character is /not/ in the supplied list of characters @cs@. Returns the -- parsed character. -- -- > consonant = noneOf "aeiou"@@ -173,12 +176,11 @@ class Parsing m => CharParsing m where -- | Parse a single character of the input, with UTF-8 decoding satisfy :: (Char -> Bool) -> m Char-#ifdef USE_DEFAULT_SIGNATURES default satisfy :: (MonadTrans t, CharParsing n, Monad n, m ~ t n) => (Char -> Bool) ->- t n Char+ m Char satisfy = lift . satisfy-#endif+ -- | @char c@ parses a single character @c@. Returns the parsed -- character (i.e. @c@). --@@ -217,7 +219,7 @@ -- > divOrMod = text "div" -- > <|> text "mod" text :: Text -> m Text- text t = t <$ string (unpack t)+ text t = t <$ string (Text.unpack t) {-# INLINE text #-} instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where@@ -332,12 +334,21 @@ text = lift . text {-# INLINE text #-} +#ifdef MIN_VERSION_parsec instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where satisfy = Parsec.satisfy char = Parsec.char notChar c = Parsec.satisfy (/= c) anyChar = Parsec.anyChar string = Parsec.string+#endif++#ifdef MIN_VERSION_attoparsec+instance Att.Chunk t => CharParsing (Att.Parser t) where+ satisfy p = fmap e2c $ Att.satisfyElem $ p . e2c+ where e2c = Att.chunkElemToChar (undefined :: t)+ {-# INLINE satisfy #-}+#endif instance CharParsing ReadP.ReadP where satisfy = ReadP.satisfy
src/Text/Parser/Combinators.hs view
@@ -1,22 +1,9 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704-#define USE_DEFAULT_SIGNATURES-#endif--#ifdef USE_DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures, TypeFamilies #-}-#endif--#if !MIN_VERSION_base(4,6,0)-#define ORPHAN_ALTERNATIVE_READP-#endif--#ifdef ORPHAN_ALTERNATIVE_READP-{-# OPTIONS_GHC -fno-warn-orphans #-}-#endif- ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Combinators@@ -38,13 +25,17 @@ , optional -- from Control.Applicative, parsec optionMaybe , skipOptional -- parsec optional , between+ , surroundedBy , some -- from Control.Applicative, parsec many1 , many -- from Control.Applicative , sepBy , sepBy1+ , sepByNonEmpty , sepEndBy1+ , sepEndByNonEmpty , sepEndBy , endBy1+ , endByNonEmpty , endBy , count , chainl@@ -57,11 +48,7 @@ ) where import Control.Applicative-#ifdef ORPHAN_ALTERNATIVE_READP-import Control.Monad (MonadPlus(..), ap)-#else-import Control.Monad (MonadPlus(..))-#endif+import Control.Monad (MonadPlus(..), replicateM, void) import Control.Monad.Trans.Class import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict@@ -71,17 +58,31 @@ import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity-import Data.Foldable (asum)-import Data.Monoid-import Data.Traversable (sequenceA)+import qualified Data.Foldable as F+import qualified Data.List.NonEmpty as NonEmpty+import Data.List.NonEmpty (NonEmpty(..))++#ifdef MIN_VERSION_parsec import qualified Text.Parsec as Parsec+#endif++#ifdef MIN_VERSION_attoparsec+import qualified Data.Attoparsec.Types as Att+import qualified Data.Attoparsec.Combinator as Att+#endif+ import qualified Text.ParserCombinators.ReadP as ReadP +#ifdef MIN_VERSION_binary+import Control.Monad (when, unless)+import qualified Data.Binary.Get as B+#endif+ -- | @choice ps@ tries to apply the parsers in the list @ps@ in order, -- until one of them succeeds. Returns the value of the succeeding -- parser. choice :: Alternative m => [m a] -> m a-choice = asum+choice = F.asum {-# INLINE choice #-} -- | @option x p@ tries to apply parser @p@. If @p@ fails without@@ -97,7 +98,7 @@ -- It only fails if @p@ fails after consuming input. It discards the result -- of @p@. (Plays the role of parsec's optional, which conflicts with Applicative's optional) skipOptional :: Alternative m => m a -> m ()-skipOptional p = (() <$ p) <|> pure ()+skipOptional p = void p <|> pure () {-# INLINE skipOptional #-} -- | @between open close p@ parses @open@, followed by @p@ and @close@.@@ -108,6 +109,12 @@ between bra ket p = bra *> p <* ket {-# INLINE between #-} +-- | @p \`surroundedBy\` f@ is @p@ surrounded by @f@. Shortcut for @between f f p@.+-- As in @between@, returns the value returned by @p@.+surroundedBy :: Applicative m => m a -> m sur -> m a+surroundedBy p bound = between bound bound p+{-# INLINE surroundedBy #-}+ -- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated -- by @sep@. Returns a list of values returned by @p@. --@@ -119,15 +126,27 @@ -- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated -- by @sep@. Returns a list of values returned by @p@. sepBy1 :: Alternative m => m a -> m sep -> m [a]-sepBy1 p sep = (:) <$> p <*> many (sep *> p)+sepBy1 p sep = F.toList <$> sepByNonEmpty p sep {-# INLINE sepBy1 #-} +-- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a non-empty list of values returned by @p@.+sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a)+sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p)+{-# INLINE sepByNonEmpty #-}+ -- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, -- separated and optionally ended by @sep@. Returns a list of values -- returned by @p@. sepEndBy1 :: Alternative m => m a -> m sep -> m [a]-sepEndBy1 p sep = flip id <$> p <*> ((flip (:) <$> (sep *> sepEndBy p sep)) <|> pure pure)+sepEndBy1 p sep = F.toList <$> sepEndByNonEmpty p sep +-- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@,+-- separated and optionally ended by @sep@. Returns a non-empty list of values+-- returned by @p@.+sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a)+sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure [])+ -- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, -- separated and optionally ended by @sep@, ie. haskell style -- statements. Returns a list of values returned by @p@.@@ -137,13 +156,19 @@ sepEndBy p sep = sepEndBy1 p sep <|> pure [] {-# INLINE sepEndBy #-} --- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, seperated+-- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a list of values returned by @p@. endBy1 :: Alternative m => m a -> m sep -> m [a] endBy1 p sep = some (p <* sep) {-# INLINE endBy1 #-} --- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated+-- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated+-- and ended by @sep@. Returns a non-empty list of values returned by @p@.+endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a)+endByNonEmpty p sep = NonEmpty.some1 (p <* sep)+{-# INLINE endByNonEmpty #-}++-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a list of values returned by @p@. -- -- > cStatements = cStatement `endBy` semi@@ -155,11 +180,10 @@ -- equal to zero, the parser equals to @return []@. Returns a list of -- @n@ values returned by @p@. count :: Applicative m => Int -> m a -> m [a]-count n p | n <= 0 = pure []- | otherwise = sequenceA (replicate n p)+count = replicateM {-# INLINE count #-} --- | @chainr p op x@ parser /zero/ or more occurrences of @p@,+-- | @chainr p op x@ parses /zero/ or more occurrences of @p@, -- separated by @op@ Returns a value obtained by a /right/ associative -- application of all functions returned by @op@ to the values returned -- by @p@. If there are no occurrences of @p@, the value @x@ is@@ -168,7 +192,7 @@ chainr p op x = chainr1 p op <|> pure x {-# INLINE chainr #-} --- | @chainl p op x@ parser /zero/ or more occurrences of @p@,+-- | @chainl p op x@ parses /zero/ or more occurrences of @p@, -- separated by @op@. Returns a value obtained by a /left/ associative -- application of all functions returned by @op@ to the values returned -- by @p@. If there are zero occurrences of @p@, the value @x@ is@@ -177,7 +201,7 @@ chainl p op x = chainl1 p op <|> pure x {-# INLINE chainl #-} --- | @chainl1 p op x@ parser /one/ or more occurrences of @p@,+-- | @chainl1 p op x@ parses /one/ or more occurrences of @p@, -- separated by @op@ Returns a value obtained by a /left/ associative -- application of all functions returned by @op@ to the values returned -- by @p@. . This parser can for example be used to eliminate left@@ -194,17 +218,17 @@ -- > <|> (-) <$ symbol "-" chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a chainl1 p op = scan where- scan = flip id <$> p <*> rst+ scan = p <**> rst rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id {-# INLINE chainl1 #-} --- | @chainr1 p op x@ parser /one/ or more occurrences of |p|,+-- | @chainr1 p op x@ parses /one/ or more occurrences of @p@, -- separated by @op@ Returns a value obtained by a /right/ associative -- application of all functions returned by @op@ to the values returned -- by @p@. chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a chainr1 p op = scan where- scan = flip id <$> p <*> rst+ scan = p <**> rst rst = (flip <$> op <*> scan) <|> pure id {-# INLINE chainr1 #-} @@ -236,7 +260,7 @@ -- | A version of many that discards its input. Specialized because it -- can often be implemented more cheaply. skipMany :: m a -> m ()- skipMany p = () <$ many p+ skipMany p = void (many p) {-# INLINE skipMany #-} -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping@@ -247,23 +271,19 @@ -- | Used to emit an error on an unexpected token unexpected :: String -> m a-#ifdef USE_DEFAULT_SIGNATURES default unexpected :: (MonadTrans t, Monad n, Parsing n, m ~ t n) =>- String -> t n a+ String -> m a unexpected = lift . unexpected {-# INLINE unexpected #-}-#endif -- | This parser only succeeds at the end of the input. This is not a -- primitive parser but it is defined using 'notFollowedBy'. -- -- > eof = notFollowedBy anyChar <?> "end of input" eof :: m ()-#ifdef USE_DEFAULT_SIGNATURES- default eof :: (MonadTrans t, Monad n, Parsing n, m ~ t n) => t n ()+ default eof :: (MonadTrans t, Monad n, Parsing n, m ~ t n) => m () eof = lift eof {-# INLINE eof #-}-#endif -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser -- does not consume any input. This parser can be used to implement the@@ -274,9 +294,7 @@ -- behaviour as follows: -- -- > keywordLet = try $ string "let" <* notFollowedBy alphaNum- notFollowedBy :: (Monad m, Show a) => m a -> m ()- notFollowedBy p = try ((try p >>= unexpected . show) <|> pure ())- {-# INLINE notFollowedBy #-}+ notFollowedBy :: Show a => m a -> m () instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where try (Lazy.StateT m) = Lazy.StateT $ try . m@@ -287,6 +305,9 @@ {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-}+ notFollowedBy (Lazy.StateT m) = Lazy.StateT+ $ \s -> notFollowedBy (fst <$> m s) >> return ((),s)+ {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where try (Strict.StateT m) = Strict.StateT $ try . m@@ -297,6 +318,9 @@ {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-}+ notFollowedBy (Strict.StateT m) = Strict.StateT+ $ \s -> notFollowedBy (fst <$> m s) >> return ((),s)+ {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where try (ReaderT m) = ReaderT $ try . m@@ -309,6 +333,8 @@ {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-}+ notFollowedBy (ReaderT m) = ReaderT $ notFollowedBy . m+ {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where try (Strict.WriterT m) = Strict.WriterT $ try m@@ -319,6 +345,9 @@ {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-}+ notFollowedBy (Strict.WriterT m) = Strict.WriterT+ $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty)+ {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where try (Lazy.WriterT m) = Lazy.WriterT $ try m@@ -329,6 +358,9 @@ {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-}+ notFollowedBy (Lazy.WriterT m) = Lazy.WriterT+ $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty)+ {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s)@@ -339,6 +371,9 @@ {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-}+ notFollowedBy (Lazy.RWST m) = Lazy.RWST+ $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty)+ {-# INLINE notFollowedBy #-} instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s)@@ -349,6 +384,9 @@ {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-}+ notFollowedBy (Strict.RWST m) = Strict.RWST+ $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty)+ {-# INLINE notFollowedBy #-} instance (Parsing m, Monad m) => Parsing (IdentityT m) where try = IdentityT . try . runIdentityT@@ -361,7 +399,10 @@ {-# INLINE unexpected #-} eof = lift eof {-# INLINE eof #-}+ notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m+ {-# INLINE notFollowedBy #-} +#ifdef MIN_VERSION_parsec instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where try = Parsec.try (<?>) = (Parsec.<?>)@@ -370,7 +411,31 @@ unexpected = Parsec.unexpected eof = Parsec.eof notFollowedBy = Parsec.notFollowedBy+#endif +#ifdef MIN_VERSION_attoparsec+instance Att.Chunk t => Parsing (Att.Parser t) where+ try = Att.try+ (<?>) = (Att.<?>)+ skipMany = Att.skipMany+ skipSome = Att.skipMany1+ unexpected = fail+ eof = Att.endOfInput+ notFollowedBy p = optional p >>= maybe (pure ()) (unexpected . show)+#endif++#ifdef MIN_VERSION_binary+instance Parsing B.Get where+ try = id+ (<?>) = flip B.label+ skipMany p = do skipped <- True <$ p <|> pure False+ when skipped $ skipMany p+ unexpected = fail+ eof = do isEof <- B.isEmpty+ unless isEof $ fail "Parsing.eof"+ notFollowedBy p = optional p >>= maybe (pure ()) (unexpected . show)+#endif+ instance Parsing ReadP.ReadP where try = id (<?>) = const@@ -378,13 +443,5 @@ skipSome = ReadP.skipMany1 unexpected = const ReadP.pfail eof = ReadP.eof--#ifdef ORPHAN_ALTERNATIVE_READP-instance Applicative ReadP.ReadP where- pure = return- (<*>) = ap--instance Alternative ReadP.ReadP where- empty = mzero- (<|>) = mplus-#endif+ notFollowedBy p = ((Just <$> p) ReadP.<++ pure Nothing)+ >>= maybe (pure ()) (unexpected . show)
src/Text/Parser/Expression.hs view
@@ -38,7 +38,7 @@ = AssocNone | AssocLeft | AssocRight- deriving (Eq,Ord,Show,Read,Ix,Enum,Bounded,Data,Typeable)+ deriving (Eq,Ord,Show,Read,Ix,Enum,Bounded,Data) -- | This data type specifies operators that work on values of type @a@. -- An operator is either binary infix or unary prefix or postfix. A@@ -74,22 +74,33 @@ -- expression parser that handles prefix signs, postfix increment and -- basic arithmetic. --+-- > import Control.Applicative ((<|>))+-- > import Text.Parser.Combinators ((<?>))+-- > import Text.Parser.Expression+-- > import Text.Parser.Token (TokenParsing, natural, parens, reserve)+-- > import Text.Parser.Token.Style (emptyOps)+-- >+-- > expr :: (Monad m, TokenParsing m) => m Integer -- > expr = buildExpressionParser table term -- > <?> "expression" -- >+-- > term :: (Monad m, TokenParsing m) => m Integer -- > term = parens expr -- > <|> natural -- > <?> "simple expression" -- >+-- > table :: (Monad m, TokenParsing m) => [[Operator m Integer]] -- > table = [ [prefix "-" negate, prefix "+" id ] -- > , [postfix "++" (+1)] -- > , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ] -- > , [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ] -- > ] -- >--- > binary name fun assoc = Infix (fun <* reservedOp name) assoc--- > prefix name fun = Prefix (fun <* reservedOp name)--- > postfix name fun = Postfix (fun <* reservedOp name)+-- > binary name fun assoc = Infix (fun <$ reservedOp name) assoc+-- > prefix name fun = Prefix (fun <$ reservedOp name)+-- > postfix name fun = Postfix (fun <$ reservedOp name)+-- >+-- > reservedOp name = reserve emptyOps name buildExpressionParser :: forall m a. (Parsing m, Applicative m) => OperatorTable m a@@ -99,23 +110,34 @@ = foldl makeParser simpleExpr operators where makeParser term ops- = let (rassoc,lassoc,nassoc,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops+ = let rassoc, lassoc, nassoc :: [m (a -> a -> a)]+ prefix, postfix :: [m (a -> a)]+ (rassoc,lassoc,nassoc,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops++ rassocOp, lassocOp, nassocOp :: m (a -> a -> a) rassocOp = choice rassoc lassocOp = choice lassoc nassocOp = choice nassoc++ prefixOp, postfixOp :: m (a -> a) prefixOp = choice prefix <?> "" postfixOp = choice postfix <?> "" + ambiguous :: String -> m x -> m y ambiguous assoc op = try $ op *> empty <?> ("ambiguous use of a " ++ assoc ++ "-associative operator") + ambiguousRight, ambiguousLeft, ambiguousNon :: m y ambiguousRight = ambiguous "right" rassocOp ambiguousLeft = ambiguous "left" lassocOp ambiguousNon = ambiguous "non" nassocOp + termP :: m a termP = (prefixP <*> term) <**> postfixP + postfixP :: m (a -> a) postfixP = postfixOp <|> pure id + prefixP :: m (a -> a) prefixP = prefixOp <|> pure id rassocP, rassocP1, lassocP, lassocP1, nassocP :: m (a -> a)
src/Text/Parser/LookAhead.hs view
@@ -1,13 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704-#define USE_DEFAULT_SIGNATURES-#endif--#ifdef USE_DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures, TypeFamilies #-}-#endif+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -36,11 +29,22 @@ import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity-import Data.Monoid import qualified Text.ParserCombinators.ReadP as ReadP-import qualified Text.Parsec as Parsec import Text.Parser.Combinators +#ifdef MIN_VERSION_parsec+import qualified Text.Parsec as Parsec+#endif++#ifdef MIN_VERSION_attoparsec+import qualified Data.Attoparsec.Types as Att+import qualified Data.Attoparsec.Combinator as Att+#endif++#ifdef MIN_VERSION_binary+import qualified Data.Binary.Get as B+#endif+ -- | Additional functionality needed to describe parsers independent of input type. class Parsing m => LookAheadParsing m where -- | @lookAhead p@ parses @p@ without consuming any input.@@ -78,8 +82,20 @@ lookAhead = IdentityT . lookAhead . runIdentityT {-# INLINE lookAhead #-} +#ifdef MIN_VERSION_parsec instance (Parsec.Stream s m t, Show t) => LookAheadParsing (Parsec.ParsecT s u m) where lookAhead = Parsec.lookAhead+#endif++#ifdef MIN_VERSION_attoparsec+instance Att.Chunk i => LookAheadParsing (Att.Parser i) where+ lookAhead = Att.lookAhead+#endif++#ifdef MIN_VERSION_binary+instance LookAheadParsing B.Get where+ lookAhead = B.lookAhead+#endif instance LookAheadParsing ReadP.ReadP where lookAhead p = ReadP.look >>= \s ->
src/Text/Parser/Permutation.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Permutation@@ -26,7 +27,7 @@ ) where import Control.Applicative-import Data.Foldable (asum)+import qualified Data.Foldable as F (asum) infixl 1 <||>, <|?> infixl 2 <$$>, <$?>@@ -45,7 +46,7 @@ {-# INLINE (<||>) #-} -- | The expression @f \<$$> p@ creates a fresh permutation parser--- consisting of parser @p@. The the final result of the permutation+-- consisting of parser @p@. The final result of the permutation -- parser is the function @f@ applied to the return value of @p@. The -- parser @p@ is not allowed to accept empty input - use the optional -- combinator ('<$?>') instead.@@ -62,7 +63,7 @@ (<$$>) f p = newPermutation f <||> p {-# INLINE (<$$>) #-} --- | The expression @perm \<||> (x,p)@ adds parser @p@ to the+-- | The expression @perm \<|?> (x,p)@ adds parser @p@ to the -- permutation parser @perm@. The parser @p@ is optional - if it can -- not be applied, the default value @x@ will be used instead. Returns -- a new permutation parser that includes the optional parser @p@.@@ -72,7 +73,7 @@ {-# INLINE (<|?>) #-} -- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser--- consisting of parser @p@. The the final result of the permutation+-- consisting of parser @p@. The final result of the permutation -- parser is the function @f@ applied to the return value of @p@. The -- parser @p@ is optional - if it can not be applied, the default value -- @x@ will be used instead.@@ -116,10 +117,11 @@ -- > tuple a b c = (a,b,c) -- transform a permutation tree into a normal parser-permute :: Alternative m => Permutation m a -> m a+permute :: forall m a. Alternative m => Permutation m a -> m a permute (Permutation def xs)- = asum (map branch xs ++ e)+ = F.asum (map branch xs ++ e) where+ e :: [m a] e = maybe [] (pure . pure) def branch (Branch perm p) = flip id <$> p <*> permute perm
src/Text/Parser/Token.hs view
@@ -1,10 +1,13 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Token@@ -35,6 +38,9 @@ , double -- :: TokenParsing m => m Double , naturalOrDouble -- :: TokenParsing m => m (Either Integer Double) , integerOrDouble -- :: TokenParsing m => m (Either Integer Double)+ , scientific -- :: TokenParsing m => m Scientific+ , naturalOrScientific -- :: TokenParsing m => m (Either Integer Scientific)+ , integerOrScientific -- :: TokenParsing m => m (Either Integer Scientific) , symbol -- :: TokenParsing m => String -> m String , textSymbol -- :: TokenParsing m => Text -> m Text , symbolic -- :: TokenParsing m => Char -> m Char@@ -89,20 +95,32 @@ import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity+import Control.Monad.State.Class as Class+import Control.Monad.Reader.Class as Class+import Control.Monad.Writer.Class as Class import Data.Char import Data.Functor.Identity import qualified Data.HashSet as HashSet import Data.HashSet (HashSet)-import Data.List (foldl')-import Data.Monoid+import qualified Data.List as List (foldl', transpose)+import Data.Scientific ( Scientific )+import qualified Data.Scientific as Sci import Data.String-import Data.Text hiding (empty,zip,foldl,foldl')+import Data.Text (Text)+import Numeric (showIntAtBase) import qualified Text.ParserCombinators.ReadP as ReadP-import qualified Text.Parsec as Parsec import Text.Parser.Char import Text.Parser.Combinators import Text.Parser.Token.Highlight +#ifdef MIN_VERSION_parsec+import qualified Text.Parsec as Parsec+#endif++#ifdef MIN_VERSION_attoparsec+import qualified Data.Attoparsec.Types as Att+#endif+ -- | Skip zero or more bytes worth of white space. More complex parsers are -- free to consider comments as white space. whiteSpace :: TokenParsing m => m ()@@ -114,8 +132,9 @@ -- sequences. The literal character is parsed according to the grammar -- rules defined in the Haskell report (which matches most programming -- languages quite closely).-charLiteral :: TokenParsing m => m Char+charLiteral :: forall m. TokenParsing m => m Char charLiteral = token (highlight CharLiteral lit) where+ lit :: m Char lit = between (char '\'') (char '\'' <?> "end of character") characterChar <?> "character" {-# INLINE charLiteral #-}@@ -125,45 +144,63 @@ -- gaps. The literal string is parsed according to the grammar rules -- defined in the Haskell report (which matches most programming -- languages quite closely).-stringLiteral :: (TokenParsing m, IsString s) => m s+stringLiteral :: forall m s. (TokenParsing m, IsString s) => m s stringLiteral = fromString <$> token (highlight StringLiteral lit) where+ lit :: m [Char] lit = Prelude.foldr (maybe id (:)) "" <$> between (char '"') (char '"' <?> "end of string") (many stringChar) <?> "string"++ stringChar :: m (Maybe Char) stringChar = Just <$> stringLetter <|> stringEscape <?> "string character"- stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + stringLetter :: m Char+ stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++ stringEscape :: m (Maybe Char) stringEscape = highlight EscapeCode $ char '\\' *> esc where+ esc :: m (Maybe Char) esc = Nothing <$ escapeGap <|> Nothing <$ escapeEmpty <|> Just <$> escapeCode++ escapeEmpty, escapeGap :: m Char escapeEmpty = char '&' escapeGap = skipSome space *> (char '\\' <?> "end of string gap") {-# INLINE stringLiteral #-} -- | This token parser behaves as 'stringLiteral', but for single-quoted -- strings.-stringLiteral' :: (TokenParsing m, IsString s) => m s+stringLiteral' :: forall m s. (TokenParsing m, IsString s) => m s stringLiteral' = fromString <$> token (highlight StringLiteral lit) where+ lit :: m [Char] lit = Prelude.foldr (maybe id (:)) "" <$> between (char '\'') (char '\'' <?> "end of string") (many stringChar) <?> "string"++ stringChar :: m (Maybe Char) stringChar = Just <$> stringLetter <|> stringEscape <?> "string character"- stringLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) + stringLetter :: m Char+ stringLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))++ stringEscape :: m (Maybe Char) stringEscape = highlight EscapeCode $ char '\\' *> esc where+ esc :: m (Maybe Char) esc = Nothing <$ escapeGap <|> Nothing <$ escapeEmpty <|> Just <$> escapeCode++ escapeEmpty, escapeGap :: m Char escapeEmpty = char '&' escapeGap = skipSome space *> (char '\\' <?> "end of string gap") {-# INLINE stringLiteral' #-} --- | This token parser parses a natural number (a positive whole+-- | This token parser parses a natural number (a non-negative whole -- number). Returns the value of the number. The number can be -- specified in 'decimal', 'hexadecimal' or -- 'octal'. The number is parsed according to the grammar@@ -178,9 +215,10 @@ -- number can be specified in 'decimal', 'hexadecimal' -- or 'octal'. The number is parsed according -- to the grammar rules in the Haskell report.-integer :: TokenParsing m => m Integer+integer :: forall m. TokenParsing m => m Integer integer = token (token (highlight Operator sgn <*> natural')) <?> "integer" where+ sgn :: m (Integer -> Integer) sgn = negate <$ char '-' <|> id <$ char '+' <|> pure id@@ -190,7 +228,7 @@ -- of the number. The number is parsed according to the grammar rules -- defined in the Haskell report. double :: TokenParsing m => m Double-double = token (highlight Number floating <?> "double")+double = token (highlight Number (Sci.toRealFloat <$> floating) <?> "double") {-# INLINE double #-} -- | This token parser parses either 'natural' or a 'float'.@@ -198,18 +236,42 @@ -- any overlap in the grammar rules for naturals and floats. The number -- is parsed according to the grammar rules defined in the Haskell report. naturalOrDouble :: TokenParsing m => m (Either Integer Double)-naturalOrDouble = token (highlight Number natDouble <?> "number")+naturalOrDouble = fmap Sci.toRealFloat <$> naturalOrScientific {-# INLINE naturalOrDouble #-} -- | This token parser is like 'naturalOrDouble', but handles -- leading @-@ or @+@. integerOrDouble :: TokenParsing m => m (Either Integer Double)-integerOrDouble = token (highlight Number iod <?> "number")- where iod = mneg <$> optional (oneOf "+-") <*> natDouble+integerOrDouble = fmap Sci.toRealFloat <$> integerOrScientific+{-# INLINE integerOrDouble #-}++-- | This token parser parses a floating point value. Returns the value+-- of the number. The number is parsed according to the grammar rules+-- defined in the Haskell report.+scientific :: TokenParsing m => m Scientific+scientific = token (highlight Number floating <?> "scientific")+{-# INLINE scientific #-}++-- | This token parser parses either 'natural' or a 'scientific'.+-- Returns the value of the number. This parsers deals with+-- any overlap in the grammar rules for naturals and floats. The number+-- is parsed according to the grammar rules defined in the Haskell report.+naturalOrScientific :: TokenParsing m => m (Either Integer Scientific)+naturalOrScientific = token (highlight Number natFloating <?> "number")+{-# INLINE naturalOrScientific #-}++-- | This token parser is like 'naturalOrScientific', but handles+-- leading @-@ or @+@.+integerOrScientific :: forall m. TokenParsing m => m (Either Integer Scientific)+integerOrScientific = token (highlight Number ios <?> "number")+ where ios :: m (Either Integer Scientific)+ ios = mneg <$> optional (oneOf "+-") <*> natFloating+ mneg (Just '-') nd = either (Left . negate) (Right . negate) nd mneg _ nd = nd-{-# INLINE integerOrDouble #-}+{-# INLINE integerOrScientific #-} + -- | Token parser @symbol s@ parses 'string' @s@ and skips -- trailing white space. symbol :: TokenParsing m => String -> m String@@ -546,18 +608,57 @@ -- -- This parser does NOT swallow trailing whitespace -escapeCode :: TokenParsing m => m Char+escapeCode :: forall m. TokenParsing m => m Char escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) <?> "escape code" where+ charControl, charNum :: m Char charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (char '^' *> (upper <|> char '@'))- charNum = toEnum . fromInteger <$> num where- num = decimal- <|> (char 'o' *> number 8 octDigit)- <|> (char 'x' *> number 16 hexDigit)+ charNum = toEnum <$> num+ where+ num :: m Int+ num = bounded 10 maxchar+ <|> (char 'o' *> bounded 8 maxchar)+ <|> (char 'x' *> bounded 16 maxchar)+ maxchar = fromEnum (maxBound :: Char)++ bounded :: Int -> Int -> m Int+ bounded base bnd = List.foldl' (\x d -> base * x + digitToInt d) 0+ <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "")+ where+ thedigits :: [m Char]+ thedigits = map char ['0'..'9'] ++ map oneOf (List.transpose [['A'..'F'],['a'..'f']])++ toomuch :: m a+ toomuch = unexpected "out-of-range numeric escape sequence"++ bounded', bounded'' :: [m Char] -> [Int] -> m [Char]+ bounded' dps@(zero:_) bds = skipSome zero *> ([] <$ notFollowedBy (choice dps) <|> bounded'' dps bds)+ <|> bounded'' dps bds+ bounded' [] _ = error "bounded called with base 0"+ bounded'' dps [] = [] <$ notFollowedBy (choice dps) <|> toomuch+ bounded'' dps (bd : bds) = let anyd :: m Char+ anyd = choice dps++ nomore :: m ()+ nomore = notFollowedBy anyd <|> toomuch+ (low, ex : high) = splitAt bd dps+ in ((:) <$> choice low <*> atMost (length bds) anyd) <* nomore+ <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds))+ <|> if not (null bds)+ then (:) <$> choice high <*> atMost (length bds - 1) anyd <* nomore+ else empty+ atMost n p | n <= 0 = pure []+ | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure []++ charEsc :: m Char charEsc = choice $ parseEsc <$> escMap+ parseEsc (c,code) = code <$ char c escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"++ charAscii :: m Char charAscii = choice $ parseAscii <$> asciiMap+ parseAscii (asc,code) = try $ code <$ string asc asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) ascii2codes, ascii3codes :: [String]@@ -570,7 +671,7 @@ ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL" --- | This parser parses a natural number (a positive whole+-- | This parser parses a natural number (a non-negative whole -- number). Returns the value of the number. The number can be -- specified in 'decimal', 'hexadecimal' or -- 'octal'. The number is parsed according to the grammar@@ -582,7 +683,7 @@ number :: TokenParsing m => Integer -> m Char -> m Integer number base baseDigit =- foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 <$> some baseDigit+ List.foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 <$> some baseDigit -- | This parser parses an integer (a whole number). This parser -- is like 'natural' except that it can be prefixed with@@ -612,22 +713,27 @@ nat = zeroNumber <|> decimal zeroNumber = char '0' *> (hexadecimal <|> octal <|> decimal <|> pure 0) <?> "" -floating :: TokenParsing m => m Double+floating :: TokenParsing m => m Scientific floating = decimal <**> fractExponent {-# INLINE floating #-} -fractExponent :: TokenParsing m => m (Integer -> Double)-fractExponent = (\fract expo n -> (fromInteger n + fract) * expo) <$> fraction <*> option 1.0 exponent'- <|> (\expo n -> fromInteger n * expo) <$> exponent' where- fraction = Prelude.foldr op 0.0 <$> (char '.' *> (some digit <?> "fraction"))- op d f = (f + fromIntegral (digitToInt d))/10.0+fractExponent :: forall m. TokenParsing m => m (Integer -> Scientific)+fractExponent = (\fract expo n -> (fromInteger n + fract) * expo) <$> fraction <*> option 1 exponent'+ <|> (\expo n -> fromInteger n * expo) <$> exponent'+ where+ fraction :: m Scientific+ fraction = List.foldl' op 0 <$> (char '.' *> (some digit <?> "fraction"))++ op f d = f + Sci.scientific (fromIntegral (digitToInt d)) (Sci.base10Exponent f - 1)++ exponent' :: m Scientific exponent' = ((\f e -> power (f e)) <$ oneOf "eE" <*> sign <*> (decimal <?> "exponent")) <?> "exponent"- power e- | e < 0 = 1.0/power(-e)- | otherwise = fromInteger (10^e) -natDouble, zeroNumFloat, decimalFloat :: TokenParsing m => m (Either Integer Double)-natDouble+ power = Sci.scientific 1 . fromInteger+++natFloating, zeroNumFloat, decimalFloat :: TokenParsing m => m (Either Integer Scientific)+natFloating = char '0' *> zeroNumFloat <|> decimalFloat zeroNumFloat@@ -637,11 +743,11 @@ <|> pure (Left 0) decimalFloat = decimal <**> option Left (try fractFloat) -fractFloat :: TokenParsing m => m (Integer -> Either Integer Double)+fractFloat :: TokenParsing m => m (Integer -> Either Integer Scientific) fractFloat = (Right .) <$> fractExponent {-# INLINE fractFloat #-} --- | Parses a positive whole number in the decimal system. Returns the+-- | Parses a non-negative whole number in the decimal system. Returns the -- value of the number. -- -- This parser does NOT swallow trailing whitespace@@ -649,7 +755,7 @@ decimal = number 10 digit {-# INLINE decimal #-} --- | Parses a positive whole number in the hexadecimal system. The number+-- | Parses a non-negative whole number in the hexadecimal system. The number -- should be prefixed with \"x\" or \"X\". Returns the value of the -- number. --@@ -658,7 +764,7 @@ hexadecimal = oneOf "xX" *> number 16 hexDigit {-# INLINE hexadecimal #-} --- | Parses a positive whole number in the octal system. The number+-- | Parses a non-negative whole number in the octal system. The number -- should be prefixed with \"o\" or \"O\". Returns the value of the -- number. --@@ -681,11 +787,34 @@ {-# INLINE unexpected #-} eof = Unhighlighted eof {-# INLINE eof #-}+ notFollowedBy (Unhighlighted m) = Unhighlighted $ notFollowedBy m+ {-# INLINE notFollowedBy #-} + instance MonadTrans Unhighlighted where lift = Unhighlighted {-# INLINE lift #-} +instance MonadState s m => MonadState s (Unhighlighted m) where+ get = lift Class.get+ {-# INLINE get #-}+ put = lift . Class.put+ {-# INLINE put #-}++instance MonadReader e m => MonadReader e (Unhighlighted m) where+ ask = lift Class.ask+ {-# INLINE ask #-}+ local f = Unhighlighted . Class.local f . runUnhighlighted+ {-# INLINE local #-}++instance MonadWriter e m => MonadWriter e (Unhighlighted m) where+ tell = lift . Class.tell+ {-# INLINE tell #-}+ listen = Unhighlighted . Class.listen . runUnhighlighted+ {-# INLINE listen #-}+ pass = Unhighlighted . Class.pass . runUnhighlighted+ {-# INLINE pass #-}+ instance TokenParsing m => TokenParsing (Unhighlighted m) where nesting (Unhighlighted m) = Unhighlighted (nesting m) {-# INLINE nesting #-}@@ -710,11 +839,33 @@ {-# INLINE unexpected #-} eof = Unspaced eof {-# INLINE eof #-}+ notFollowedBy (Unspaced m) = Unspaced $ notFollowedBy m+ {-# INLINE notFollowedBy #-} instance MonadTrans Unspaced where lift = Unspaced {-# INLINE lift #-} +instance MonadState s m => MonadState s (Unspaced m) where+ get = lift Class.get+ {-# INLINE get #-}+ put = lift . Class.put+ {-# INLINE put #-}++instance MonadReader e m => MonadReader e (Unspaced m) where+ ask = lift Class.ask+ {-# INLINE ask #-}+ local f = Unspaced . Class.local f . runUnspaced+ {-# INLINE local #-}++instance MonadWriter e m => MonadWriter e (Unspaced m) where+ tell = lift . Class.tell+ {-# INLINE tell #-}+ listen = Unspaced . Class.listen . runUnspaced+ {-# INLINE listen #-}+ pass = Unspaced . Class.pass . runUnspaced+ {-# INLINE pass #-}+ instance TokenParsing m => TokenParsing (Unspaced m) where nesting (Unspaced m) = Unspaced (nesting m) {-# INLINE nesting #-}@@ -739,11 +890,33 @@ {-# INLINE unexpected #-} eof = Unlined eof {-# INLINE eof #-}+ notFollowedBy (Unlined m) = Unlined $ notFollowedBy m+ {-# INLINE notFollowedBy #-} instance MonadTrans Unlined where lift = Unlined {-# INLINE lift #-} +instance MonadState s m => MonadState s (Unlined m) where+ get = lift Class.get+ {-# INLINE get #-}+ put = lift . Class.put+ {-# INLINE put #-}++instance MonadReader e m => MonadReader e (Unlined m) where+ ask = lift Class.ask+ {-# INLINE ask #-}+ local f = Unlined . Class.local f . runUnlined+ {-# INLINE local #-}++instance MonadWriter e m => MonadWriter e (Unlined m) where+ tell = lift . Class.tell+ {-# INLINE tell #-}+ listen = Unlined . Class.listen . runUnlined+ {-# INLINE listen #-}+ pass = Unlined . Class.pass . runUnlined+ {-# INLINE pass #-}+ instance TokenParsing m => TokenParsing (Unlined m) where nesting (Unlined m) = Unlined (nesting m) {-# INLINE nesting #-}@@ -754,6 +927,12 @@ highlight h (Unlined m) = Unlined (highlight h m) {-# INLINE highlight #-} +#ifdef MIN_VERSION_parsec instance Parsec.Stream s m Char => TokenParsing (Parsec.ParsecT s u m)+#endif++#ifdef MIN_VERSION_attoparsec+instance Att.Chunk t => TokenParsing (Att.Parser t)+#endif instance TokenParsing ReadP.ReadP
src/Text/Parser/Token/Style.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Token.Style@@ -40,9 +38,9 @@ ) where import Control.Applicative+import Control.Monad (void) import qualified Data.HashSet as HashSet import Data.HashSet (HashSet)-import Data.Monoid import Data.Data import Text.Parser.Combinators import Text.Parser.Char@@ -56,7 +54,7 @@ , _commentEnd :: String -- ^ String that ends a multiline comment , _commentLine :: String -- ^ String that starts a single line comment , _commentNesting :: Bool -- ^ Can we nest multiline comments?- } deriving (Eq,Ord,Show,Read,Data,Typeable)+ } deriving (Eq,Ord,Show,Read,Data) -- | This is a lens that can edit the string that starts a multiline comment. --@@ -104,7 +102,7 @@ -- | Use this to easily build the definition of whiteSpace for your MonadParser -- given a comment style and an underlying someWhiteSpace parser-buildSomeSpaceParser :: CharParsing m => m () -> CommentStyle -> m ()+buildSomeSpaceParser :: forall m. CharParsing m => m () -> CommentStyle -> m () buildSomeSpaceParser simpleSpace (CommentStyle startStyle endStyle lineStyle nestingStyle) | noLine && noMulti = skipSome (simpleSpace <?> "") | noLine = skipSome (simpleSpace <|> multiLineComment <?> "")@@ -113,18 +111,23 @@ where noLine = null lineStyle noMulti = null startStyle++ oneLineComment, multiLineComment, inComment, inCommentMulti :: m () oneLineComment = try (string lineStyle) *> skipMany (satisfy (/= '\n')) multiLineComment = try (string startStyle) *> inComment inComment = if nestingStyle then inCommentMulti else inCommentSingle inCommentMulti- = () <$ try (string endStyle)+ = void (try (string endStyle)) <|> multiLineComment *> inCommentMulti <|> skipSome (noneOf startEnd) *> inCommentMulti <|> oneOf startEnd *> inCommentMulti <?> "end of comment"+ startEnd = nub (endStyle ++ startStyle)++ inCommentSingle :: m () inCommentSingle- = () <$ try (string endStyle)+ = void (try (string endStyle)) <|> skipSome (noneOf startEnd) *> inCommentSingle <|> oneOf startEnd *> inCommentSingle <?> "end of comment"
+ tests/QuickCheck.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++module Main+( main+) where++import Control.Applicative++#ifdef MIN_VERSION_attoparsec+import Data.Attoparsec.Text (parseOnly)+#endif+import Data.Either+import Data.String++import Test.QuickCheck+import Test.QuickCheck.Instances ()++#ifdef MIN_VERSION_parsec+import Text.Parsec.Prim as P (parse)+#endif+import Text.Parser.Char+import Text.Parser.Combinators+import Text.ParserCombinators.ReadP (readP_to_S)++import System.Exit++-- -------------------------------------------------------------------------- --+-- Run tests with different parser frameworks++-- Instead of letting quick check pick the parser framework as a test parameter+-- it may be better to just run all tests for each parser framework.++newtype P a = P (forall m. (Monad m, CharParsing m) => m a)++data TestParser a = TestParser String (P a -> String -> Either String a)++instance Show (TestParser a) where show (TestParser n _) = n++#ifdef MIN_VERSION_attoparsec+pAtto :: TestParser a+pAtto = TestParser "attoparsec" $ \(P p) -> parseOnly p . fromString+#endif++#ifdef MIN_VERSION_parsec+pParsec :: TestParser a+pParsec = TestParser "parsec" $ \(P p) -> either (Left . show) Right . parse p "test input"+#endif++pReadP :: TestParser a+pReadP = TestParser "ReadP" $ \(P p) s -> case readP_to_S p s of+ [] -> Left "parseFailed"+ (a,_):_ -> Right a++instance Arbitrary (TestParser a) where+ arbitrary = elements ps+ where+ ps = [pReadP]+#ifdef MIN_VERSION_attoparsec+ ++ [pAtto]+#endif+#ifdef MIN_VERSION_parsec+ ++ [pParsec]+#endif++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = mapM quickCheckResult tests >>= \x -> case filter (not . passed) x of+ [] -> exitSuccess+ _ -> exitFailure+ where+ passed Success{} = True+ passed _ = False++-- -------------------------------------------------------------------------- --+-- Tests++tests :: [Property]+tests =+ [ property prop_notFollowedBy0+ , property prop_notFollowedBy1+ , property prop_notFollowedBy2+ , property prop_notFollowedBy3+ ]++-- -------------------------------------------------------------------------- --+-- Properties++prop_notFollowedBy0 :: TestParser Char -> Char -> Char -> Bool+prop_notFollowedBy0 (TestParser _ p) x y = either (\_ -> x == y) (/= y)+ $ p (P (notFollowedBy (char y) *> anyChar)) [x]++prop_notFollowedBy1 :: TestParser Char -> Char -> Bool+prop_notFollowedBy1 (TestParser _ p) x = either (\_ -> x == x) (/= x)+ $ p (P (notFollowedBy (char x) *> anyChar)) [x]++prop_notFollowedBy2 :: TestParser Char -> String -> Char -> Bool+prop_notFollowedBy2 (TestParser _ p) x y = isLeft+ $ p (P (anyChar *> notFollowedBy (char y) *> char y)) x++prop_notFollowedBy3 :: TestParser () -> Char -> Bool+prop_notFollowedBy3 (TestParser _ p) x = isRight+ $ p (P (notFollowedBy (char x) <|> char x *> pure ())) [x]
− tests/doctests.hs
@@ -1,30 +0,0 @@-module Main where--import Build_doctests (deps)-import Control.Applicative-import Control.Monad-import Data.List-import System.Directory-import System.FilePath-import Test.DocTest--main :: IO ()-main = getSources >>= \sources -> doctest $- "-isrc"- : "-idist/build/autogen"- : "-optP-include"- : "-optPdist/build/autogen/cabal_macros.h"- : "-hide-all-packages"- : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c