parsers-0.12.10/0000755000000000000000000000000007346545000011523 5ustar0000000000000000parsers-0.12.10/.travis.yml0000755000000000000000000002144407346545000013644 0ustar0000000000000000# This Travis job script has been generated by a script via # # haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' # # For more information, see https://github.com/haskell-CI/haskell-ci # # version: 0.3.20190425 # language: c dist: xenial git: # whether to recursively clone submodules submodules: false notifications: irc: channels: - irc.freenode.org#haskell-lens skip_join: true template: - "\"\\x0313parsers\\x03/\\x0306%{branch}\\x03 \\x0314%{commit}\\x03 %{build_url} %{message}\"" cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - compiler: ghc-8.8.1 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} env: GHCHEAD=true - compiler: ghc-8.6.5 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - compiler: ghc-8.4.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} - compiler: ghc-8.2.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} - compiler: ghc-8.0.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} - compiler: ghc-7.10.3 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-2.4"]}} - compiler: ghc-7.8.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-2.4"]}} - compiler: ghc-7.6.3 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.6.3","cabal-install-2.4"]}} - compiler: ghc-7.4.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.4.2","cabal-install-2.4"]}} - compiler: ghc-7.2.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.2.2","cabal-install-2.4"]}} - compiler: ghc-7.0.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.0.4","cabal-install-2.4"]}} - compiler: ghc-head addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-head","cabal-install-head"]}} env: GHCHEAD=true allow_failures: - compiler: ghc-head - compiler: ghc-7.0.4 - compiler: ghc-7.2.2 - compiler: ghc-8.8.1 before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal - CABALHOME=$HOME/.cabal - export PATH="$CABALHOME/bin:$PATH" - TOP=$(pwd) - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - echo $HCNUMVER - CABAL="$CABAL -vnormal+nowrap+markoutput" - set -o pipefail - | echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk echo 'BEGIN { state = "output"; }' >> .colorful.awk echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk echo ' if (state == "cabal") {' >> .colorful.awk echo ' print blue($0)' >> .colorful.awk echo ' } else {' >> .colorful.awk echo ' print $0' >> .colorful.awk echo ' }' >> .colorful.awk echo '}' >> .colorful.awk - cat .colorful.awk - | color_cabal_output () { awk -f $TOP/.colorful.awk } - echo text | color_cabal_output install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - TEST=--enable-tests - BENCH=--enable-benchmarks - GHCHEAD=${GHCHEAD-false} - rm -f $CABALHOME/config - | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config echo "remote-build-reporting: anonymous" >> $CABALHOME/config echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config echo "world-file: $CABALHOME/world" >> $CABALHOME/config echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config echo "installdir: $CABALHOME/bin" >> $CABALHOME/config echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config echo "store-dir: $CABALHOME/store" >> $CABALHOME/config echo "install-dirs user" >> $CABALHOME/config echo " prefix: $CABALHOME" >> $CABALHOME/config echo "repository hackage.haskell.org" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - | if $GHCHEAD; then echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config echo "repository head.hackage" >> $CABALHOME/config echo " url: http://head.hackage.haskell.org/" >> $CABALHOME/config echo " secure: True" >> $CABALHOME/config echo " root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740" >> $CABALHOME/config echo " 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb" >> $CABALHOME/config echo " 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e" >> $CABALHOME/config echo " key-threshold: 3" >> $CABALHOME/config fi - cat $CABALHOME/config - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v - if [ $HCNUMVER -eq 80801 ] ; then ${CABAL} v2-install -w ${HC} -j2 hlint --constraint='hlint ==2.1.*' | color_cabal_output ; fi # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo 'packages: "."' >> cabal.project - | echo "write-ghc-environment-files: always" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(parsers)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... - ${CABAL} v2-sdist all | color_cabal_output # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo 'packages: "parsers-*/*.cabal"' >> cabal.project - | echo "write-ghc-environment-files: always" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(parsers)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true # Building with tests and benchmarks... # build & run tests, build benchmarks - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # Testing... - ${CABAL} v2-test -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # HLint.. - if [ $HCNUMVER -eq 80801 ] ; then (cd parsers-* && hlint --cpp-ansi --cpp-define=HLINT src) ; fi # cabal check... - (cd parsers-* && ${CABAL} -vnormal check) # haddock... - ${CABAL} v2-haddock -w ${HC} ${TEST} ${BENCH} all | color_cabal_output # REGENDATA ["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"] # EOF parsers-0.12.10/CHANGELOG.markdown0000755000000000000000000000662607346545000014573 0ustar00000000000000000.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 parsers-0.12.10/HLint.hs0000755000000000000000000000011507346545000013075 0ustar0000000000000000import "hint" HLint.Default ignore "Reduce duplication" ignore "Use String" parsers-0.12.10/LICENSE0000644000000000000000000000266007346545000012534 0ustar0000000000000000Copyright 2011-2013 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. parsers-0.12.10/README.markdown0000755000000000000000000000120507346545000014225 0ustar0000000000000000parsers ======= [![Hackage](https://img.shields.io/hackage/v/parsers.svg)](https://hackage.haskell.org/package/parsers) [![Build Status](https://secure.travis-ci.org/ekmett/parsers.png?branch=master)](http://travis-ci.org/ekmett/parsers) 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 parsers-0.12.10/Setup.hs0000644000000000000000000000006007346545000013153 0ustar0000000000000000import Distribution.Simple main = defaultMain parsers-0.12.10/parsers.cabal0000644000000000000000000000634407346545000014175 0ustar0000000000000000name: parsers category: Text, Parsing version: 0.12.10 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/parsers/ bug-reports: http://github.com/ekmett/parsers/issues copyright: Copyright (C) 2010-2013 Edward A. Kmett synopsis: Parsing combinators 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==7.0.4 , GHC==7.2.2 , GHC==7.4.2 , GHC==7.6.3 , GHC==7.8.4 , GHC==7.10.3 , GHC==8.0.2 , GHC==8.2.2 , GHC==8.4.4 , GHC==8.6.5 , GHC==8.8.1 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown HLint.hs source-repository head type: git location: git://github.com/ekmett/parsers.git 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: Text.Parser.Char Text.Parser.Combinators Text.Parser.LookAhead Text.Parser.Permutation Text.Parser.Expression Text.Parser.Token Text.Parser.Token.Style Text.Parser.Token.Highlight hs-source-dirs: src ghc-options: -Wall -fno-warn-wrong-do-bind -fwarn-monomorphism-restriction -fwarn-incomplete-record-updates if impl(ghc >= 7.2) ghc-options: -fwarn-identities -fwarn-incomplete-uni-patterns if impl(ghc >= 7.10) ghc-options: -fno-warn-trustworthy-safe build-depends: base >= 4.3 && < 5, base-orphans >= 0.3 && < 1, charset >= 0.3 && < 1, containers >= 0.4 && < 0.7, semigroups >= 0.12 && < 1, text >= 0.10 && < 1.3, transformers >= 0.2 && < 0.6, mtl >= 2.0.1 && < 2.3, scientific >= 0.3 && < 0.4, unordered-containers >= 0.2 && < 0.3 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.14 test-suite quickcheck type: exitcode-stdio-1.0 main-is: QuickCheck.hs default-language: Haskell2010 build-depends: base == 4.*, bytestring, parsers, QuickCheck, quickcheck-instances ghc-options: -Wall -threaded hs-source-dirs: tests if flag(parsec) build-depends: parsec >= 3 if flag(attoparsec) build-depends: attoparsec parsers-0.12.10/src/Text/Parser/0000755000000000000000000000000007346545000014472 5ustar0000000000000000parsers-0.12.10/src/Text/Parser/Char.hs0000644000000000000000000002626207346545000015713 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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 -- Copyright : (c) Edward Kmett 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- -- Parsers for character streams -- ----------------------------------------------------------------------------- module Text.Parser.Char ( -- * Combinators oneOf -- :: CharParsing m => [Char] -> m Char , noneOf -- :: CharParsing m => [Char] -> m Char , oneOfSet -- :: CharParsing m => CharSet -> m Char , noneOfSet -- :: CharParsing m => CharSet -> m Char , spaces -- :: CharParsing m => m () , space -- :: CharParsing m => m Char , newline -- :: CharParsing m => m Char , tab -- :: CharParsing m => m Char , upper -- :: CharParsing m => m Char , lower -- :: CharParsing m => m Char , alphaNum -- :: CharParsing m => m Char , letter -- :: CharParsing m => m Char , digit -- :: CharParsing m => m Char , hexDigit -- :: CharParsing m => m Char , octDigit -- :: CharParsing m => m Char , satisfyRange -- :: CharParsing m => Char -> Char -> m Char -- * Class , CharParsing(..) ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad.Trans.Class import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity import Control.Monad (MonadPlus(..)) import Data.Char import Data.CharSet (CharSet(..)) import qualified Data.CharSet as CharSet import Data.Foldable import qualified Data.IntSet as IntSet #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.Text import qualified Text.ParserCombinators.ReadP as ReadP 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'. -- -- > vowel = oneOf "aeiou" oneOf :: CharParsing m => [Char] -> m Char oneOf xs = oneOfSet (CharSet.fromList xs) {-# INLINE oneOf #-} {-# ANN oneOf "HLint: ignore Use String" #-} -- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current -- character is /not/ in the supplied list of characters @cs@. Returns the -- parsed character. -- -- > consonant = noneOf "aeiou" noneOf :: CharParsing m => [Char] -> m Char noneOf xs = noneOfSet (CharSet.fromList xs) {-# INLINE noneOf #-} {-# ANN noneOf "HLint: ignore Use String" #-} -- | @oneOfSet cs@ succeeds if the current character is in the supplied -- set of characters @cs@. Returns the parsed character. See also -- 'satisfy'. -- -- > vowel = oneOf "aeiou" oneOfSet :: CharParsing m => CharSet -> m Char oneOfSet (CharSet True _ is) = satisfy (\c -> IntSet.member (fromEnum c) is) oneOfSet (CharSet False _ is) = satisfy (\c -> not (IntSet.member (fromEnum c) is)) {-# INLINE oneOfSet #-} -- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current -- character is /not/ in the supplied list of characters @cs@. Returns the -- parsed character. -- -- > consonant = noneOf "aeiou" noneOfSet :: CharParsing m => CharSet -> m Char noneOfSet s = oneOfSet (CharSet.complement s) {-# INLINE noneOfSet #-} -- | Skips /zero/ or more white space characters. See also 'skipMany'. spaces :: CharParsing m => m () spaces = skipMany space "white space" {-# INLINE spaces #-} -- | Parses a white space character (any character which satisfies 'isSpace') -- Returns the parsed character. space :: CharParsing m => m Char space = satisfy isSpace "space" {-# INLINE space #-} -- | Parses a newline character (\'\\n\'). Returns a newline character. newline :: CharParsing m => m Char newline = char '\n' "new-line" {-# INLINE newline #-} -- | Parses a tab character (\'\\t\'). Returns a tab character. tab :: CharParsing m => m Char tab = char '\t' "tab" {-# INLINE tab #-} -- | Parses an upper case letter. Returns the parsed character. upper :: CharParsing m => m Char upper = satisfy isUpper "uppercase letter" {-# INLINE upper #-} -- | Parses a lower case character. Returns the parsed character. lower :: CharParsing m => m Char lower = satisfy isLower "lowercase letter" {-# INLINE lower #-} -- | Parses a letter or digit. Returns the parsed character. alphaNum :: CharParsing m => m Char alphaNum = satisfy isAlphaNum "letter or digit" {-# INLINE alphaNum #-} -- | Parses a letter (an upper case or lower case character). Returns the -- parsed character. letter :: CharParsing m => m Char letter = satisfy isAlpha "letter" {-# INLINE letter #-} -- | Parses a digit. Returns the parsed character. digit :: CharParsing m => m Char digit = satisfy isDigit "digit" {-# INLINE digit #-} -- | Parses a hexadecimal digit (a digit or a letter between \'a\' and -- \'f\' or \'A\' and \'F\'). Returns the parsed character. hexDigit :: CharParsing m => m Char hexDigit = satisfy isHexDigit "hexadecimal digit" {-# INLINE hexDigit #-} -- | Parses an octal digit (a character between \'0\' and \'7\'). Returns -- the parsed character. octDigit :: CharParsing m => m Char octDigit = satisfy isOctDigit "octal digit" {-# INLINE octDigit #-} satisfyRange :: CharParsing m => Char -> Char -> m Char satisfyRange a z = satisfy (\c -> c >= a && c <= z) {-# INLINE satisfyRange #-} -- | Additional functionality needed to parse character streams. 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) -> m Char satisfy = lift . satisfy #endif -- | @char c@ parses a single character @c@. Returns the parsed -- character (i.e. @c@). -- -- /e.g./ -- -- @semiColon = 'char' ';'@ char :: Char -> m Char char c = satisfy (c ==) show [c] {-# INLINE char #-} -- | @notChar c@ parses any single character other than @c@. Returns the parsed -- character. notChar :: Char -> m Char notChar c = satisfy (c /=) {-# INLINE notChar #-} -- | This parser succeeds for any character. Returns the parsed character. anyChar :: m Char anyChar = satisfy (const True) {-# INLINE anyChar #-} -- | @string s@ parses a sequence of characters given by @s@. Returns -- the parsed string (i.e. @s@). -- -- > divOrMod = string "div" -- > <|> string "mod" string :: String -> m String string s = s <$ try (traverse_ char s) show s {-# INLINE string #-} -- | @text t@ parses a sequence of characters determined by the text @t@ Returns -- the parsed text fragment (i.e. @t@). -- -- Using @OverloadedStrings@: -- -- > divOrMod = text "div" -- > <|> text "mod" text :: Text -> m Text text t = t <$ string (unpack t) {-# INLINE text #-} instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where satisfy = lift . satisfy {-# INLINE satisfy #-} char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where satisfy = lift . satisfy {-# INLINE satisfy #-} char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where satisfy = lift . satisfy {-# INLINE satisfy #-} char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where satisfy = lift . satisfy {-# INLINE satisfy #-} char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where satisfy = lift . satisfy {-# INLINE satisfy #-} char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where satisfy = lift . satisfy {-# INLINE satisfy #-} char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where satisfy = lift . satisfy {-# INLINE satisfy #-} char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} string = lift . string {-# INLINE string #-} text = lift . text {-# INLINE text #-} instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where satisfy = lift . satisfy {-# INLINE satisfy #-} char = lift . char {-# INLINE char #-} notChar = lift . notChar {-# INLINE notChar #-} anyChar = lift anyChar {-# INLINE anyChar #-} string = lift . string {-# INLINE string #-} 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 char = ReadP.char notChar c = ReadP.satisfy (/= c) anyChar = ReadP.get string = ReadP.string parsers-0.12.10/src/Text/Parser/Combinators.hs0000644000000000000000000004004107346545000017305 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 -- Copyright : (c) Edward Kmett 2011-2012 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- -- Alternative parser combinators -- ----------------------------------------------------------------------------- module Text.Parser.Combinators ( -- * Parsing Combinators choice , option , 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 , chainr , chainl1 , chainr1 , manyTill -- * Parsing Class , Parsing(..) ) where import Control.Applicative import Control.Monad (MonadPlus(..)) import Control.Monad.Trans.Class import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity import Data.Foldable (asum) import Data.List.NonEmpty #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #ifdef ORPHAN_ALTERNATIVE_READP import Data.Orphans () #endif import Data.Traversable (sequenceA) #endif #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 {-# INLINE choice #-} -- | @option x p@ tries to apply parser @p@. If @p@ fails without -- consuming input, it returns the value @x@, otherwise the value -- returned by @p@. -- -- > priority = option 0 (digitToInt <$> digit) option :: Alternative m => a -> m a -> m a option x p = p <|> pure x {-# INLINE option #-} -- | @skipOptional p@ tries to apply parser @p@. It will parse @p@ or nothing. -- 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 () {-# INLINE skipOptional #-} -- | @between open close p@ parses @open@, followed by @p@ and @close@. -- Returns the value returned by @p@. -- -- > braces = between (symbol "{") (symbol "}") between :: Applicative m => m bra -> m ket -> m a -> m a 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@. -- -- > commaSep p = p `sepBy` (symbol ",") sepBy :: Alternative m => m a -> m sep -> m [a] sepBy p sep = sepBy1 p sep <|> pure [] {-# INLINE sepBy #-} -- | @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 = 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 = 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@. -- -- > haskellStatements = haskellStatement `sepEndBy` semi sepEndBy :: Alternative m => m a -> m sep -> m [a] sepEndBy p sep = sepEndBy1 p sep <|> pure [] {-# INLINE sepEndBy #-} -- | @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 #-} -- | @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 = 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 endBy :: Alternative m => m a -> m sep -> m [a] endBy p sep = many (p <* sep) {-# INLINE endBy #-} -- | @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 returned by @p@. count :: Applicative m => Int -> m a -> m [a] count n p | n <= 0 = pure [] | otherwise = sequenceA (replicate n p) {-# INLINE count #-} -- | @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 -- returned. chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a chainr p op x = chainr1 p op <|> pure x {-# INLINE chainr #-} -- | @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 -- returned. chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a chainl p op x = chainl1 p op <|> pure x {-# INLINE chainl #-} -- | @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 -- recursion which typically occurs in expression grammars. -- -- > expr = term `chainl1` addop -- > term = factor `chainl1` mulop -- > factor = parens expr <|> integer -- > -- > mulop = (*) <$ symbol "*" -- > <|> div <$ symbol "/" -- > -- > addop = (+) <$ symbol "+" -- > <|> (-) <$ symbol "-" chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a chainl1 p op = scan where scan = p <**> rst rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id {-# INLINE chainl1 #-} -- | @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 = p <**> rst rst = (flip <$> op <*> scan) <|> pure id {-# INLINE chainr1 #-} -- | @manyTill p end@ applies parser @p@ /zero/ or more times until -- parser @end@ succeeds. Returns the list of values returned by @p@. -- This parser can be used to scan comments: -- -- > simpleComment = do{ string "")) -- > } -- -- Note the overlapping parsers @anyChar@ and @string \"-->\"@, and -- therefore the use of the 'try' combinator. manyTill :: Alternative m => m a -> m end -> m [a] manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) {-# INLINE manyTill #-} infixr 0 -- | Additional functionality needed to describe parsers independent of input type. class Alternative m => Parsing m where -- | Take a parser that may consume input, and on failure, go back to -- where we started and fail as if we didn't consume input. try :: m a -> m a -- | Give a parser a name () :: m a -> String -> m a -- | 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 {-# INLINE skipMany #-} -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping -- its result. (aka skipMany1 in parsec) skipSome :: m a -> m () skipSome p = p *> skipMany p {-# INLINE skipSome #-} -- | 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 -> 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) => 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 -- \'longest match\' rule. For example, when recognizing keywords (for -- example @let@), we want to make sure that a keyword is not followed -- by a legal identifier character, in which case the keyword is -- actually an identifier (for example @lets@). We can program this -- behaviour as follows: -- -- > keywordLet = try $ string "let" <* notFollowedBy alphaNum 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 {-# INLINE try #-} Lazy.StateT m l = Lazy.StateT $ \s -> m s l {-# INLINE () #-} unexpected = lift . unexpected {-# 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 {-# INLINE try #-} Strict.StateT m l = Strict.StateT $ \s -> m s l {-# INLINE () #-} unexpected = lift . unexpected {-# 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 {-# INLINE try #-} ReaderT m l = ReaderT $ \e -> m e l {-# INLINE () #-} skipMany (ReaderT m) = ReaderT $ skipMany . m {-# INLINE skipMany #-} unexpected = lift . unexpected {-# 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 {-# INLINE try #-} Strict.WriterT m l = Strict.WriterT (m l) {-# INLINE () #-} unexpected = lift . unexpected {-# 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 {-# INLINE try #-} Lazy.WriterT m l = Lazy.WriterT (m l) {-# INLINE () #-} unexpected = lift . unexpected {-# 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) {-# INLINE try #-} Lazy.RWST m l = Lazy.RWST $ \r s -> m r s l {-# INLINE () #-} unexpected = lift . unexpected {-# 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) {-# INLINE try #-} Strict.RWST m l = Strict.RWST $ \r s -> m r s l {-# INLINE () #-} unexpected = lift . unexpected {-# 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 {-# INLINE try #-} IdentityT m l = IdentityT (m l) {-# INLINE () #-} skipMany = IdentityT . skipMany . runIdentityT {-# INLINE skipMany #-} unexpected = lift . unexpected {-# 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.) skipMany = Parsec.skipMany skipSome = Parsec.skipMany1 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 skipMany = ReadP.skipMany skipSome = ReadP.skipMany1 unexpected = const ReadP.pfail eof = ReadP.eof notFollowedBy p = ((Just <$> p) ReadP.<++ pure Nothing) >>= maybe (pure ()) (unexpected . show) parsers-0.12.10/src/Text/Parser/Expression.hs0000644000000000000000000001504707346545000017174 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Expression -- Copyright : (c) Edward Kmett 2011-2012 -- (c) Paolo Martini 2007 -- (c) Daan Leijen 1999-2001, -- License : BSD-style (see the LICENSE file) -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- -- A helper module to parse \"expressions\". -- Builds a parser given a table of operators and associativities. -- ----------------------------------------------------------------------------- module Text.Parser.Expression ( Assoc(..), Operator(..), OperatorTable , buildExpressionParser ) where import Control.Applicative import Text.Parser.Combinators import Data.Data hiding (Infix, Prefix) import Data.Ix ----------------------------------------------------------- -- Assoc and OperatorTable ----------------------------------------------------------- -- | This data type specifies the associativity of operators: left, right -- or none. data Assoc = AssocNone | AssocLeft | AssocRight deriving (Eq,Ord,Show,Read,Ix,Enum,Bounded,Data,Typeable) -- | This data type specifies operators that work on values of type @a@. -- An operator is either binary infix or unary prefix or postfix. A -- binary operator has also an associated associativity. data Operator m a = Infix (m (a -> a -> a)) Assoc | Prefix (m (a -> a)) | Postfix (m (a -> a)) -- | An @OperatorTable m a@ is a list of @Operator m a@ -- lists. The list is ordered in descending -- precedence. All operators in one list have the same precedence (but -- may have a different associativity). type OperatorTable m a = [[Operator m a]] ----------------------------------------------------------- -- Convert an OperatorTable and basic term parser into -- a full fledged expression parser ----------------------------------------------------------- -- | @buildExpressionParser table term@ builds an expression parser for -- terms @term@ with operators from @table@, taking the associativity -- and precedence specified in @table@ into account. Prefix and postfix -- operators of the same precedence can only occur once (i.e. @--2@ is -- not allowed if @-@ is prefix negate). Prefix and postfix operators -- of the same precedence associate to the left (i.e. if @++@ is -- postfix increment, than @-2++@ equals @-1@, not @-3@). -- -- The @buildExpressionParser@ takes care of all the complexity -- involved in building expression parser. Here is an example of an -- 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) -- > -- > reservedOp name = reserve emptyOps name buildExpressionParser :: forall m a. (Parsing m, Applicative m) => OperatorTable m a -> m a -> m a buildExpressionParser operators simpleExpr = foldl makeParser simpleExpr operators where makeParser term 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) rassocP = (flip <$> rassocOp <*> (termP <**> rassocP1) <|> ambiguousLeft <|> ambiguousNon) rassocP1 = rassocP <|> pure id lassocP = ((flip <$> lassocOp <*> termP) <**> ((.) <$> lassocP1) <|> ambiguousRight <|> ambiguousNon) lassocP1 = lassocP <|> pure id nassocP = (flip <$> nassocOp <*> termP) <**> (ambiguousRight <|> ambiguousLeft <|> ambiguousNon <|> pure id) in termP <**> (rassocP <|> lassocP <|> nassocP <|> pure id) "operator" splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix) = case assoc of AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix) AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix) AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix) splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix) = (rassoc,lassoc,nassoc,op:prefix,postfix) splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix) = (rassoc,lassoc,nassoc,prefix,op:postfix) parsers-0.12.10/src/Text/Parser/LookAhead.hs0000644000000000000000000000725007346545000016661 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 #define USE_DEFAULT_SIGNATURES #endif #ifdef USE_DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures, TypeFamilies #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.LookAhead -- Copyright : (c) Edward Kmett 2011-2013 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- -- Parsers that can 'lookAhead'. ----------------------------------------------------------------------------- module Text.Parser.LookAhead ( -- * Parsing Combinators LookAheadParsing(..) ) where import Control.Monad (MonadPlus(..)) import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import qualified Text.ParserCombinators.ReadP as ReadP 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. lookAhead :: m a -> m a instance (LookAheadParsing m, MonadPlus m) => LookAheadParsing (Lazy.StateT s m) where lookAhead (Lazy.StateT m) = Lazy.StateT $ lookAhead . m {-# INLINE lookAhead #-} instance (LookAheadParsing m, MonadPlus m) => LookAheadParsing (Strict.StateT s m) where lookAhead (Strict.StateT m) = Strict.StateT $ lookAhead . m {-# INLINE lookAhead #-} instance (LookAheadParsing m, MonadPlus m) => LookAheadParsing (ReaderT e m) where lookAhead (ReaderT m) = ReaderT $ lookAhead . m {-# INLINE lookAhead #-} instance (LookAheadParsing m, MonadPlus m, Monoid w) => LookAheadParsing (Strict.WriterT w m) where lookAhead (Strict.WriterT m) = Strict.WriterT $ lookAhead m {-# INLINE lookAhead #-} instance (LookAheadParsing m, MonadPlus m, Monoid w) => LookAheadParsing (Lazy.WriterT w m) where lookAhead (Lazy.WriterT m) = Lazy.WriterT $ lookAhead m {-# INLINE lookAhead #-} instance (LookAheadParsing m, MonadPlus m, Monoid w) => LookAheadParsing (Lazy.RWST r w s m) where lookAhead (Lazy.RWST m) = Lazy.RWST $ \r s -> lookAhead (m r s) {-# INLINE lookAhead #-} instance (LookAheadParsing m, MonadPlus m, Monoid w) => LookAheadParsing (Strict.RWST r w s m) where lookAhead (Strict.RWST m) = Strict.RWST $ \r s -> lookAhead (m r s) {-# INLINE lookAhead #-} instance (LookAheadParsing m, Monad m) => LookAheadParsing (IdentityT m) where 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 -> ReadP.choice $ map (return . fst) $ ReadP.readP_to_S p s parsers-0.12.10/src/Text/Parser/Permutation.hs0000644000000000000000000001262707346545000017345 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Permutation -- Copyright : (c) Edward Kmett 2011-2012 -- (c) Paolo Martini 2007 -- (c) Daan Leijen 1999-2001 -- License : BSD-style -- -- Maintainer : ekmett@gmail.com -- Stability : provisional -- Portability : non-portable -- -- This module implements permutation parsers. The algorithm is described in: -- -- /Parsing Permutation Phrases,/ -- by Arthur Baars, Andres Loh and Doaitse Swierstra. -- Published as a functional pearl at the Haskell Workshop 2001. -- ----------------------------------------------------------------------------- module Text.Parser.Permutation ( Permutation , permute , (<||>), (<$$>) , (<|?>), (<$?>) ) where import Control.Applicative import Data.Foldable (asum) infixl 1 <||>, <|?> infixl 2 <$$>, <$?> ---------------------------------------------------------------- -- Building a permutation parser ---------------------------------------------------------------- -- | The expression @perm \<||> p@ adds parser @p@ to the permutation -- parser @perm@. The parser @p@ is not allowed to accept empty input - -- use the optional combinator ('<|?>') instead. Returns a -- new permutation parser that includes @p@. (<||>) :: Functor m => Permutation m (a -> b) -> m a -> Permutation m b (<||>) = add {-# INLINE (<||>) #-} -- | The expression @f \<$$> p@ creates a fresh permutation parser -- 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. -- -- If the function @f@ takes more than one parameter, the type variable -- @b@ is instantiated to a functional type which combines nicely with -- the adds parser @p@ to the ('<||>') combinator. This -- results in stylized code where a permutation parser starts with a -- combining function @f@ followed by the parsers. The function @f@ -- gets its parameters in the order in which the parsers are specified, -- but actual input can be in any order. (<$$>) :: Functor m => (a -> b) -> m a -> Permutation m b (<$$>) f p = newPermutation f <||> p {-# INLINE (<$$>) #-} -- | 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@. (<|?>) :: Functor m => Permutation m (a -> b) -> (a, m a) -> Permutation m b (<|?>) perm (x,p) = addOpt perm x p {-# INLINE (<|?>) #-} -- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser -- 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. (<$?>) :: Functor m => (a -> b) -> (a, m a) -> Permutation m b (<$?>) f (x,p) = newPermutation f <|?> (x,p) {-# INLINE (<$?>) #-} ---------------------------------------------------------------- -- The permutation tree ---------------------------------------------------------------- -- | The type @Permutation m a@ denotes a permutation parser that, -- when converted by the 'permute' function, parses -- using the base parsing monad @m@ and returns a value of -- type @a@ on success. -- -- Normally, a permutation parser is first build with special operators -- like ('<||>') and than transformed into a normal parser -- using 'permute'. data Permutation m a = Permutation (Maybe a) [Branch m a] instance Functor m => Functor (Permutation m) where fmap f (Permutation x xs) = Permutation (fmap f x) (fmap f <$> xs) data Branch m a = forall b. Branch (Permutation m (b -> a)) (m b) instance Functor m => Functor (Branch m) where fmap f (Branch perm p) = Branch (fmap (f.) perm) p -- | The parser @permute perm@ parses a permutation of parser described -- by @perm@. For example, suppose we want to parse a permutation of: -- an optional string of @a@'s, the character @b@ and an optional @c@. -- This can be described by: -- -- > test = permute (tuple <$?> ("",some (char 'a')) -- > <||> char 'b' -- > <|?> ('_',char 'c')) -- > where -- > tuple a b c = (a,b,c) -- transform a permutation tree into a normal parser permute :: forall m a. Alternative m => Permutation m a -> m a permute (Permutation def xs) = asum (map branch xs ++ e) where e :: [m a] e = maybe [] (pure . pure) def branch (Branch perm p) = flip id <$> p <*> permute perm -- build permutation trees newPermutation :: (a -> b) -> Permutation m (a -> b) newPermutation f = Permutation (Just f) [] {-# INLINE newPermutation #-} add :: Functor m => Permutation m (a -> b) -> m a -> Permutation m b add perm@(Permutation _mf fs) p = Permutation Nothing (first:map insert fs) where first = Branch perm p insert (Branch perm' p') = Branch (add (fmap flip perm') p) p' addOpt :: Functor m => Permutation m (a -> b) -> a -> m a -> Permutation m b addOpt perm@(Permutation mf fs) x p = Permutation (fmap ($ x) mf) (first:map insert fs) where first = Branch perm p insert (Branch perm' p') = Branch (addOpt (fmap flip perm') x p) p' parsers-0.12.10/src/Text/Parser/Token.hs0000644000000000000000000010717407346545000016120 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Token -- Copyright : (c) Edward Kmett 2011 -- (c) Daan Leijen 1999-2001 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- Portability : non-portable -- -- Parsers that comprehend whitespace and identifier styles -- -- > idStyle = haskellIdents { styleReserved = ... } -- > identifier = ident idStyle -- > reserved = reserve idStyle -- ----------------------------------------------------------------------------- module Text.Parser.Token ( -- * Token Parsing whiteSpace -- :: TokenParsing m => m () , charLiteral -- :: TokenParsing m => m Char , stringLiteral -- :: (TokenParsing m, IsString s) => m s , stringLiteral' -- :: (TokenParsing m, IsString s) => m s , natural -- :: TokenParsing m => m Integer , integer -- :: TokenParsing m => m Integer , 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 , parens -- :: TokenParsing m => m a -> m a , braces -- :: TokenParsing m => m a -> m a , angles -- :: TokenParsing m => m a -> m a , brackets -- :: TokenParsing m => m a -> m a , comma -- :: TokenParsing m => m Char , colon -- :: TokenParsing m => m Char , dot -- :: TokenParsing m => m Char , semiSep -- :: TokenParsing m => m a -> m [a] , semiSep1 -- :: TokenParsing m => m a -> m [a] , commaSep -- :: TokenParsing m => m a -> m [a] , commaSep1 -- :: TokenParsing m => m a -> m [a] -- ** Token Parsing Class , TokenParsing(..) -- ** Token Parsing Transformers , Unspaced(..) , Unlined(..) , Unhighlighted(..) -- ** /Non-Token/ Parsers , decimal -- :: TokenParsing m => m Integer , hexadecimal -- :: TokenParsing m => m Integer , octal -- :: TokenParsing m => m Integer , characterChar -- :: TokenParsing m => m Char , integer' -- :: TokenParsing m => m Integer -- * Identifiers , IdentifierStyle(..) , liftIdentifierStyle -- :: (MonadTrans t, Monad m) => IdentifierStyle m -> IdentifierStyle (t m) , ident -- :: (TokenParsing m, IsString s) => IdentifierStyle m -> m s , reserve -- :: TokenParsing m => IdentifierStyle m -> String -> m () , reserveText -- :: TokenParsing m => IdentifierStyle m -> Text -> m () -- ** Lenses and Traversals , styleName , styleStart , styleLetter , styleChars , styleReserved , styleHighlight , styleReservedHighlight , styleHighlights ) where import Control.Applicative import Control.Monad (MonadPlus(..), when) import Control.Monad.Trans.Class import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Trans.RWS.Lazy as Lazy 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', transpose) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.Scientific ( Scientific ) import qualified Data.Scientific as Sci import Data.String import Data.Text hiding (empty,zip,foldl',take,map,length,splitAt,null,transpose) import Numeric (showIntAtBase) import qualified Text.ParserCombinators.ReadP as ReadP 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 () whiteSpace = someSpace <|> pure () {-# INLINE whiteSpace #-} -- | This token parser parses a single literal character. Returns the -- literal character value. This parsers deals correctly with escape -- sequences. The literal character is parsed according to the grammar -- rules defined in the Haskell report (which matches most programming -- languages quite closely). 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 #-} -- | This token parser parses a literal string. Returns the literal -- string value. This parsers deals correctly with escape sequences and -- gaps. The literal string is parsed according to the grammar rules -- defined in the Haskell report (which matches most programming -- languages quite closely). 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 :: 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' :: 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 :: 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 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 -- rules in the Haskell report. natural :: TokenParsing m => m Integer natural = token natural' {-# INLINE natural #-} -- | This token parser parses an integer (a whole number). This parser -- is like 'natural' except that it can be prefixed with -- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The -- number can be specified in 'decimal', 'hexadecimal' -- or 'octal'. The number is parsed according -- to the grammar rules in the Haskell report. 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 {-# INLINE integer #-} -- | 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. double :: TokenParsing m => m Double double = token (highlight Number (Sci.toRealFloat <$> floating) "double") {-# INLINE double #-} -- | This token parser parses either 'natural' or a 'float'. -- 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. naturalOrDouble :: TokenParsing m => m (Either Integer Double) 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 = 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 integerOrScientific #-} -- | Token parser @symbol s@ parses 'string' @s@ and skips -- trailing white space. symbol :: TokenParsing m => String -> m String symbol name = token (highlight Symbol (string name)) {-# INLINE symbol #-} -- | Token parser @textSymbol t@ parses 'text' @s@ and skips -- trailing white space. textSymbol :: TokenParsing m => Text -> m Text textSymbol name = token (highlight Symbol (text name)) {-# INLINE textSymbol #-} -- | Token parser @symbolic s@ parses 'char' @s@ and skips -- trailing white space. symbolic :: TokenParsing m => Char -> m Char symbolic name = token (highlight Symbol (char name)) {-# INLINE symbolic #-} -- | Token parser @parens p@ parses @p@ enclosed in parenthesis, -- returning the value of @p@. parens :: TokenParsing m => m a -> m a parens = nesting . between (symbolic '(') (symbolic ')') {-# INLINE parens #-} -- | Token parser @braces p@ parses @p@ enclosed in braces (\'{\' and -- \'}\'), returning the value of @p@. braces :: TokenParsing m => m a -> m a braces = nesting . between (symbolic '{') (symbolic '}') {-# INLINE braces #-} -- | Token parser @angles p@ parses @p@ enclosed in angle brackets (\'\<\' -- and \'>\'), returning the value of @p@. angles :: TokenParsing m => m a -> m a angles = nesting . between (symbolic '<') (symbolic '>') {-# INLINE angles #-} -- | Token parser @brackets p@ parses @p@ enclosed in brackets (\'[\' -- and \']\'), returning the value of @p@. brackets :: TokenParsing m => m a -> m a brackets = nesting . between (symbolic '[') (symbolic ']') {-# INLINE brackets #-} -- | Token parser @comma@ parses the character \',\' and skips any -- trailing white space. Returns the string \",\". comma :: TokenParsing m => m Char comma = symbolic ',' {-# INLINE comma #-} -- | Token parser @colon@ parses the character \':\' and skips any -- trailing white space. Returns the string \":\". colon :: TokenParsing m => m Char colon = symbolic ':' {-# INLINE colon #-} -- | Token parser @dot@ parses the character \'.\' and skips any -- trailing white space. Returns the string \".\". dot :: TokenParsing m => m Char dot = symbolic '.' {-# INLINE dot #-} -- | Token parser @semiSep p@ parses /zero/ or more occurrences of @p@ -- separated by 'semi'. Returns a list of values returned by @p@. semiSep :: TokenParsing m => m a -> m [a] semiSep p = sepBy p semi {-# INLINE semiSep #-} -- | Token parser @semiSep1 p@ parses /one/ or more occurrences of @p@ -- separated by 'semi'. Returns a list of values returned by @p@. semiSep1 :: TokenParsing m => m a -> m [a] semiSep1 p = sepBy1 p semi {-# INLINE semiSep1 #-} -- | Token parser @commaSep p@ parses /zero/ or more occurrences of -- @p@ separated by 'comma'. Returns a list of values returned -- by @p@. commaSep :: TokenParsing m => m a -> m [a] commaSep p = sepBy p comma {-# INLINE commaSep #-} -- | Token parser @commaSep1 p@ parses /one/ or more occurrences of -- @p@ separated by 'comma'. Returns a list of values returned -- by @p@. commaSep1 :: TokenParsing m => m a -> m [a] commaSep1 p = sepBy1 p comma {-# INLINE commaSep1 #-} -- | Additional functionality that is needed to tokenize input while ignoring whitespace. class CharParsing m => TokenParsing m where -- | Usually, someSpace consists of /one/ or more occurrences of a 'space'. -- Some parsers may choose to recognize line comments or block (multi line) -- comments as white space as well. someSpace :: m () someSpace = skipSome (satisfy isSpace) {-# INLINE someSpace #-} -- | Called when we enter a nested pair of symbols. -- Overloadable to enable disabling layout nesting :: m a -> m a nesting = id {-# INLINE nesting #-} -- | The token parser |semi| parses the character \';\' and skips -- any trailing white space. Returns the character \';\'. Overloadable to -- permit automatic semicolon insertion or Haskell-style layout. semi :: m Char semi = token (satisfy (';'==) ";") {-# INLINE semi #-} -- | Tag a region of parsed text with a bit of semantic information. -- Most parsers won't use this, but it is indispensible for highlighters. highlight :: Highlight -> m a -> m a highlight _ a = a {-# INLINE highlight #-} -- | @token p@ first applies parser @p@ and then the 'whiteSpace' -- parser, returning the value of @p@. Every lexical -- token (token) is defined using @token@, this way every parse -- starts at a point without white space. Parsers that use @token@ are -- called /token/ parsers in this document. -- -- The only point where the 'whiteSpace' parser should be -- called explicitly is the start of the main parser in order to skip -- any leading white space. -- -- Alternatively, one might define 'token' as first parsing 'whiteSpace' -- and then parser @p@. By parsing whiteSpace first, the parser is able -- to return before parsing additional whiteSpace, improving laziness. -- -- > mainParser = sum <$ whiteSpace <*> many (token digit) <* eof token :: m a -> m a token p = p <* (someSpace <|> pure ()) instance (TokenParsing m, MonadPlus m) => TokenParsing (Lazy.StateT s m) where nesting (Lazy.StateT m) = Lazy.StateT $ nesting . m {-# INLINE nesting #-} someSpace = lift someSpace {-# INLINE someSpace #-} semi = lift semi {-# INLINE semi #-} highlight h (Lazy.StateT m) = Lazy.StateT $ highlight h . m {-# INLINE highlight #-} instance (TokenParsing m, MonadPlus m) => TokenParsing (Strict.StateT s m) where nesting (Strict.StateT m) = Strict.StateT $ nesting . m {-# INLINE nesting #-} someSpace = lift someSpace {-# INLINE someSpace #-} semi = lift semi {-# INLINE semi #-} highlight h (Strict.StateT m) = Strict.StateT $ highlight h . m {-# INLINE highlight #-} instance (TokenParsing m, MonadPlus m) => TokenParsing (ReaderT e m) where nesting (ReaderT m) = ReaderT $ nesting . m {-# INLINE nesting #-} someSpace = lift someSpace {-# INLINE someSpace #-} semi = lift semi {-# INLINE semi #-} highlight h (ReaderT m) = ReaderT $ highlight h . m {-# INLINE highlight #-} instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Strict.WriterT w m) where nesting (Strict.WriterT m) = Strict.WriterT $ nesting m {-# INLINE nesting #-} someSpace = lift someSpace {-# INLINE someSpace #-} semi = lift semi {-# INLINE semi #-} highlight h (Strict.WriterT m) = Strict.WriterT $ highlight h m {-# INLINE highlight #-} instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Lazy.WriterT w m) where nesting (Lazy.WriterT m) = Lazy.WriterT $ nesting m {-# INLINE nesting #-} someSpace = lift someSpace {-# INLINE someSpace #-} semi = lift semi {-# INLINE semi #-} highlight h (Lazy.WriterT m) = Lazy.WriterT $ highlight h m {-# INLINE highlight #-} instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Lazy.RWST r w s m) where nesting (Lazy.RWST m) = Lazy.RWST $ \r s -> nesting (m r s) {-# INLINE nesting #-} someSpace = lift someSpace {-# INLINE someSpace #-} semi = lift semi {-# INLINE semi #-} highlight h (Lazy.RWST m) = Lazy.RWST $ \r s -> highlight h (m r s) {-# INLINE highlight #-} instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Strict.RWST r w s m) where nesting (Strict.RWST m) = Strict.RWST $ \r s -> nesting (m r s) {-# INLINE nesting #-} someSpace = lift someSpace {-# INLINE someSpace #-} semi = lift semi {-# INLINE semi #-} highlight h (Strict.RWST m) = Strict.RWST $ \r s -> highlight h (m r s) {-# INLINE highlight #-} instance (TokenParsing m, MonadPlus m) => TokenParsing (IdentityT m) where nesting = IdentityT . nesting . runIdentityT {-# INLINE nesting #-} someSpace = lift someSpace {-# INLINE someSpace #-} semi = lift semi {-# INLINE semi #-} highlight h = IdentityT . highlight h . runIdentityT {-# INLINE highlight #-} -- | Used to describe an input style for constructors, values, operators, etc. data IdentifierStyle m = IdentifierStyle { _styleName :: String , _styleStart :: m Char , _styleLetter :: m Char , _styleReserved :: HashSet String , _styleHighlight :: Highlight , _styleReservedHighlight :: Highlight } -- | This lens can be used to update the name for this style of identifier. -- -- @'styleName' :: Lens' ('IdentifierStyle' m) 'String'@ styleName :: Functor f => (String -> f String) -> IdentifierStyle m -> f (IdentifierStyle m) styleName f is = (\n -> is { _styleName = n }) <$> f (_styleName is) {-# INLINE styleName #-} -- | This lens can be used to update the action used to recognize the first letter in an identifier. -- -- @'styleStart' :: Lens' ('IdentifierStyle' m) (m 'Char')@ styleStart :: Functor f => (m Char -> f (m Char)) -> IdentifierStyle m -> f (IdentifierStyle m) styleStart f is = (\n -> is { _styleStart = n }) <$> f (_styleStart is) {-# INLINE styleStart #-} -- | This lens can be used to update the action used to recognize subsequent letters in an identifier. -- -- @'styleLetter' :: Lens' ('IdentifierStyle' m) (m 'Char')@ styleLetter :: Functor f => (m Char -> f (m Char)) -> IdentifierStyle m -> f (IdentifierStyle m) styleLetter f is = (\n -> is { _styleLetter = n }) <$> f (_styleLetter is) {-# INLINE styleLetter #-} -- | This is a traversal of both actions in contained in an 'IdentifierStyle'. -- -- @'styleChars' :: Traversal ('IdentifierStyle' m) ('IdentifierStyle' n) (m 'Char') (n 'Char')@ styleChars :: Applicative f => (m Char -> f (n Char)) -> IdentifierStyle m -> f (IdentifierStyle n) styleChars f is = (\n m -> is { _styleStart = n, _styleLetter = m }) <$> f (_styleStart is) <*> f (_styleLetter is) {-# INLINE styleChars #-} -- | This is a lens that can be used to modify the reserved identifier set. -- -- @'styleReserved' :: Lens' ('IdentifierStyle' m) ('HashSet' 'String')@ styleReserved :: Functor f => (HashSet String -> f (HashSet String)) -> IdentifierStyle m -> f (IdentifierStyle m) styleReserved f is = (\n -> is { _styleReserved = n }) <$> f (_styleReserved is) {-# INLINE styleReserved #-} -- | This is a lens that can be used to modify the highlight used for this identifier set. -- -- @'styleHighlight' :: Lens' ('IdentifierStyle' m) 'Highlight'@ styleHighlight :: Functor f => (Highlight -> f Highlight) -> IdentifierStyle m -> f (IdentifierStyle m) styleHighlight f is = (\n -> is { _styleHighlight = n }) <$> f (_styleHighlight is) {-# INLINE styleHighlight #-} -- | This is a lens that can be used to modify the highlight used for reserved identifiers in this identifier set. -- -- @'styleReservedHighlight' :: Lens' ('IdentifierStyle' m) 'Highlight'@ styleReservedHighlight :: Functor f => (Highlight -> f Highlight) -> IdentifierStyle m -> f (IdentifierStyle m) styleReservedHighlight f is = (\n -> is { _styleReservedHighlight = n }) <$> f (_styleReservedHighlight is) {-# INLINE styleReservedHighlight #-} -- | This is a traversal that can be used to modify the highlights used for both non-reserved and reserved identifiers in this identifier set. -- -- @'styleHighlights' :: Traversal' ('IdentifierStyle' m) 'Highlight'@ styleHighlights :: Applicative f => (Highlight -> f Highlight) -> IdentifierStyle m -> f (IdentifierStyle m) styleHighlights f is = (\n m -> is { _styleHighlight = n, _styleReservedHighlight = m }) <$> f (_styleHighlight is) <*> f (_styleReservedHighlight is) {-# INLINE styleHighlights #-} -- | Lift an identifier style into a monad transformer -- -- Using @over@ from the @lens@ package: -- -- @'liftIdentifierStyle' = over 'styleChars' 'lift'@ liftIdentifierStyle :: (MonadTrans t, Monad m) => IdentifierStyle m -> IdentifierStyle (t m) liftIdentifierStyle = runIdentity . styleChars (Identity . lift) {-# INLINE liftIdentifierStyle #-} -- | parse a reserved operator or identifier using a given style reserve :: (TokenParsing m, Monad m) => IdentifierStyle m -> String -> m () reserve s name = token $ try $ do _ <- highlight (_styleReservedHighlight s) $ string name notFollowedBy (_styleLetter s) "end of " ++ show name {-# INLINE reserve #-} -- | parse a reserved operator or identifier using a given style given 'Text'. reserveText :: (TokenParsing m, Monad m) => IdentifierStyle m -> Text -> m () reserveText s name = token $ try $ do _ <- highlight (_styleReservedHighlight s) $ text name notFollowedBy (_styleLetter s) "end of " ++ show name {-# INLINE reserveText #-} -- | Parse a non-reserved identifier or symbol ident :: (TokenParsing m, Monad m, IsString s) => IdentifierStyle m -> m s ident s = fmap fromString $ token $ try $ do name <- highlight (_styleHighlight s) ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name return name {-# INLINE ident #-} -- * Utilities -- | This parser parses a character literal without the surrounding quotation marks. -- -- This parser does NOT swallow trailing whitespace characterChar :: TokenParsing m => m Char charEscape, charLetter :: TokenParsing m => m Char characterChar = charLetter <|> charEscape "literal character" {-# INLINE characterChar #-} charEscape = highlight EscapeCode $ char '\\' *> escapeCode {-# INLINE charEscape #-} charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) {-# INLINE charLetter #-} -- | This parser parses a literal string. Returns the literal -- string value. This parsers deals correctly with escape sequences and -- gaps. The literal string is parsed according to the grammar rules -- defined in the Haskell report (which matches most programming -- languages quite closely). -- -- This parser does NOT swallow trailing whitespace 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 <$> 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 = 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 (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] ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO" , "SI","EM","FS","GS","RS","US","SP"] ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK" ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK" ,"SYN","ETB","CAN","SUB","ESC","DEL"] ascii2, ascii3 :: String 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 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 -- rules in the Haskell report. -- -- This parser does NOT swallow trailing whitespace. natural' :: TokenParsing m => m Integer natural' = highlight Number nat "natural" number :: TokenParsing m => Integer -> m Char -> m Integer number base baseDigit = 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 -- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The -- number can be specified in 'decimal', 'hexadecimal' -- or 'octal'. The number is parsed according -- to the grammar rules in the Haskell report. -- -- This parser does NOT swallow trailing whitespace. -- -- Also, unlike the 'integer' parser, this parser does not admit spaces -- between the sign and the number. integer' :: TokenParsing m => m Integer integer' = int "integer" {-# INLINE integer' #-} sign :: TokenParsing m => m (Integer -> Integer) sign = highlight Operator $ negate <$ char '-' <|> id <$ char '+' <|> pure id int :: TokenParsing m => m Integer int = {-token-} sign <*> highlight Number nat nat, zeroNumber :: TokenParsing m => m Integer nat = zeroNumber <|> decimal zeroNumber = char '0' *> (hexadecimal <|> octal <|> decimal <|> pure 0) "" floating :: TokenParsing m => m Scientific floating = decimal <**> fractExponent {-# INLINE floating #-} 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 = 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 = Sci.scientific 1 . fromInteger natFloating, zeroNumFloat, decimalFloat :: TokenParsing m => m (Either Integer Scientific) natFloating = char '0' *> zeroNumFloat <|> decimalFloat zeroNumFloat = Left <$> (hexadecimal <|> octal) <|> decimalFloat <|> pure 0 <**> try fractFloat <|> pure (Left 0) decimalFloat = decimal <**> option Left (try fractFloat) fractFloat :: TokenParsing m => m (Integer -> Either Integer Scientific) fractFloat = (Right .) <$> fractExponent {-# INLINE fractFloat #-} -- | Parses a non-negative whole number in the decimal system. Returns the -- value of the number. -- -- This parser does NOT swallow trailing whitespace decimal :: TokenParsing m => m Integer decimal = number 10 digit {-# INLINE decimal #-} -- | 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. -- -- This parser does NOT swallow trailing whitespace hexadecimal :: TokenParsing m => m Integer hexadecimal = oneOf "xX" *> number 16 hexDigit {-# INLINE hexadecimal #-} -- | 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. -- -- This parser does NOT swallow trailing whitespace octal :: TokenParsing m => m Integer octal = oneOf "oO" *> number 8 octDigit {-# INLINE octal #-} -- | This is a parser transformer you can use to disable syntax highlighting -- over a range of text you are parsing. newtype Unhighlighted m a = Unhighlighted { runUnhighlighted :: m a } deriving (Functor,Applicative,Alternative,Monad,MonadPlus,CharParsing) instance Parsing m => Parsing (Unhighlighted m) where try (Unhighlighted m) = Unhighlighted $ try m {-# INLINE try #-} Unhighlighted m l = Unhighlighted $ m l {-# INLINE () #-} unexpected = Unhighlighted . unexpected {-# 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 #-} someSpace = Unhighlighted someSpace {-# INLINE someSpace #-} semi = Unhighlighted semi {-# INLINE semi #-} highlight _ m = m {-# INLINE highlight #-} -- | This is a parser transformer you can use to disable the automatic trailing -- space consumption of a Token parser. newtype Unspaced m a = Unspaced { runUnspaced :: m a } deriving (Functor,Applicative,Alternative,Monad,MonadPlus,CharParsing) instance Parsing m => Parsing (Unspaced m) where try (Unspaced m) = Unspaced $ try m {-# INLINE try #-} Unspaced m l = Unspaced $ m l {-# INLINE () #-} unexpected = Unspaced . unexpected {-# 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 #-} someSpace = empty {-# INLINE someSpace #-} semi = Unspaced semi {-# INLINE semi #-} highlight h (Unspaced m) = Unspaced (highlight h m) {-# INLINE highlight #-} -- | This is a parser transformer you can use to disable the automatic trailing -- newline (but not whitespace-in-general) consumption of a Token parser. newtype Unlined m a = Unlined { runUnlined :: m a } deriving (Functor,Applicative,Alternative,Monad,MonadPlus,CharParsing) instance Parsing m => Parsing (Unlined m) where try (Unlined m) = Unlined $ try m {-# INLINE try #-} Unlined m l = Unlined $ m l {-# INLINE () #-} unexpected = Unlined . unexpected {-# 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 #-} someSpace = skipMany (satisfy $ \c -> c /= '\n' && isSpace c) {-# INLINE someSpace #-} semi = Unlined semi {-# INLINE semi #-} 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 parsers-0.12.10/src/Text/Parser/Token/0000755000000000000000000000000007346545000015552 5ustar0000000000000000parsers-0.12.10/src/Text/Parser/Token/Highlight.hs0000644000000000000000000000237307346545000020022 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Token.Highlight -- Copyright : (C) 2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- -- Highlighting isn't strictly a parsing concern, but it makes more sense -- to annotate a parser with highlighting information than to require -- someone to completely reimplement all of the combinators to add -- this functionality later when they need it. -- ---------------------------------------------------------------------------- module Text.Parser.Token.Highlight ( Highlight(..) ) where -- | Tags used by the 'Text.Parser.Token.TokenParsing' 'Text.Parser.Token.highlight' combinator. data Highlight = EscapeCode | Number | Comment | CharLiteral | StringLiteral | Constant | Statement | Special | Symbol | Identifier | ReservedIdentifier | Operator | ReservedOperator | Constructor | ReservedConstructor | ConstructorOperator | ReservedConstructorOperator | BadInput | Unbound | Layout | MatchedSymbols | LiterateComment | LiterateSyntax deriving (Eq,Ord,Show,Read,Enum,Bounded) parsers-0.12.10/src/Text/Parser/Token/Style.hs0000644000000000000000000001566107346545000017217 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Text.Parser.Token.Style -- Copyright : (c) Edward Kmett 2011-2012 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : provisional -- Portability : non-portable -- -- A toolbox for specifying comment and identifier styles -- -- This must be imported directly as it is not re-exported elsewhere -- ----------------------------------------------------------------------------- module Text.Parser.Token.Style ( -- * Comment and white space styles CommentStyle(..) -- ** Lenses , commentStart , commentEnd , commentLine , commentNesting -- ** Common Comment Styles , emptyCommentStyle , javaCommentStyle , scalaCommentStyle , haskellCommentStyle , buildSomeSpaceParser -- * Identifier Styles , emptyIdents, haskellIdents, haskell98Idents -- * Operator Styles , emptyOps, haskellOps, haskell98Ops ) where import Control.Applicative import qualified Data.HashSet as HashSet import Data.HashSet (HashSet) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import Data.Data import Text.Parser.Combinators import Text.Parser.Char import Text.Parser.Token import Text.Parser.Token.Highlight import Data.List (nub) -- | How to deal with comments. data CommentStyle = CommentStyle { _commentStart :: String -- ^ String that starts a multiline comment , _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) -- | This is a lens that can edit the string that starts a multiline comment. -- -- @'commentStart' :: Lens' 'CommentStyle' 'String'@ commentStart :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle commentStart f (CommentStyle s e l n) = (\s' -> CommentStyle s' e l n) <$> f s {-# INLINE commentStart #-} -- | This is a lens that can edit the string that ends a multiline comment. -- -- @'commentEnd' :: Lens' 'CommentStyle' 'String'@ commentEnd :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle commentEnd f (CommentStyle s e l n) = (\e' -> CommentStyle s e' l n) <$> f e {-# INLINE commentEnd #-} -- | This is a lens that can edit the string that starts a single line comment. -- -- @'commentLine' :: Lens' 'CommentStyle' 'String'@ commentLine :: Functor f => (String -> f String) -> CommentStyle -> f CommentStyle commentLine f (CommentStyle s e l n) = (\l' -> CommentStyle s e l' n) <$> f l {-# INLINE commentLine #-} -- | This is a lens that can edit whether we can nest multiline comments. -- -- @'commentNesting' :: Lens' 'CommentStyle' 'Bool'@ commentNesting :: Functor f => (Bool -> f Bool) -> CommentStyle -> f CommentStyle commentNesting f (CommentStyle s e l n) = CommentStyle s e l <$> f n {-# INLINE commentNesting #-} -- | No comments at all emptyCommentStyle :: CommentStyle emptyCommentStyle = CommentStyle "" "" "" True -- | Use java-style comments javaCommentStyle :: CommentStyle javaCommentStyle = CommentStyle "/*" "*/" "//" False -- | Use scala-style comments scalaCommentStyle :: CommentStyle scalaCommentStyle = CommentStyle "/*" "*/" "//" True -- | Use haskell-style comments haskellCommentStyle :: CommentStyle haskellCommentStyle = CommentStyle "{-" "-}" "--" True -- | Use this to easily build the definition of whiteSpace for your MonadParser -- given a comment style and an underlying someWhiteSpace parser buildSomeSpaceParser :: forall m. CharParsing m => m () -> CommentStyle -> m () buildSomeSpaceParser simpleSpace (CommentStyle startStyle endStyle lineStyle nestingStyle) | noLine && noMulti = skipSome (simpleSpace "") | noLine = skipSome (simpleSpace <|> multiLineComment "") | noMulti = skipSome (simpleSpace <|> oneLineComment "") | otherwise = skipSome (simpleSpace <|> oneLineComment <|> multiLineComment "") 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) <|> multiLineComment *> inCommentMulti <|> skipSome (noneOf startEnd) *> inCommentMulti <|> oneOf startEnd *> inCommentMulti "end of comment" startEnd = nub (endStyle ++ startStyle) inCommentSingle :: m () inCommentSingle = () <$ try (string endStyle) <|> skipSome (noneOf startEnd) *> inCommentSingle <|> oneOf startEnd *> inCommentSingle "end of comment" set :: [String] -> HashSet String set = HashSet.fromList -- | A simple operator style based on haskell with no reserved operators emptyOps :: TokenParsing m => IdentifierStyle m emptyOps = IdentifierStyle { _styleName = "operator" , _styleStart = _styleLetter emptyOps , _styleLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" , _styleReserved = mempty , _styleHighlight = Operator , _styleReservedHighlight = ReservedOperator } -- | A simple operator style based on haskell with the operators from Haskell 98. haskell98Ops, haskellOps :: TokenParsing m => IdentifierStyle m haskell98Ops = emptyOps { _styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"] } haskellOps = haskell98Ops -- | A simple identifier style based on haskell with no reserve words emptyIdents :: TokenParsing m => IdentifierStyle m emptyIdents = IdentifierStyle { _styleName = "identifier" , _styleStart = letter <|> char '_' , _styleLetter = alphaNum <|> oneOf "_'" , _styleReserved = set [] , _styleHighlight = Identifier , _styleReservedHighlight = ReservedIdentifier } -- | A simple identifier style based on haskell with only the reserved words from Haskell 98. haskell98Idents :: TokenParsing m => IdentifierStyle m haskell98Idents = emptyIdents { _styleReserved = set haskell98ReservedIdents } -- | A simple identifier style based on haskell with the reserved words from Haskell 98 and some common extensions. haskellIdents :: TokenParsing m => IdentifierStyle m haskellIdents = haskell98Idents { _styleLetter = _styleLetter haskell98Idents <|> char '#' , _styleReserved = set $ haskell98ReservedIdents ++ ["foreign","import","export","primitive","_ccall_","_casm_" ,"forall"] } haskell98ReservedIdents :: [String] haskell98ReservedIdents = ["let","in","case","of","if","then","else","data","type" ,"class","default","deriving","do","import","infix" ,"infixl","infixr","instance","module","newtype" ,"where","primitive" -- "as","qualified","hiding" ] parsers-0.12.10/tests/0000755000000000000000000000000007346545000012665 5ustar0000000000000000parsers-0.12.10/tests/QuickCheck.hs0000644000000000000000000000640307346545000015236 0ustar0000000000000000{-# 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.String #if MIN_VERSION_base(4,7,0) import Data.Either #endif 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] -- -------------------------------------------------------------------------- -- -- Utils #if !MIN_VERSION_base(4,7,0) isLeft :: Either a b -> Bool isLeft = either (const True) (const False) isRight :: Either a b -> Bool isRight = either (const False) (const True) #endif