parsers-0.12.4/0000755000000000000000000000000012730064020011435 5ustar0000000000000000parsers-0.12.4/.travis.yml0000644000000000000000000001010612730064020013544 0ustar0000000000000000# This file has been generated -- see https://github.com/hvr/multi-ghc-travis language: c sudo: false cache: directories: - $HOME/.cabsnap - $HOME/.cabal/packages before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar matrix: include: - env: CABALVER=1.18 GHCVER=7.0.4 compiler: ": #GHC 7.0.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.0.4,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.2.2 compiler: ": #GHC 7.2.2" addons: {apt: {packages: [cabal-install-1.18,ghc-7.2.2,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.3 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=8.0.1 compiler: ": #GHC 8.0.1" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,hlint], sources: [hvr-ghc]}} before_install: - unset CC - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH install: - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; then zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; fi - travis_retry cabal update -v - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then echo "cabal build-cache HIT"; rm -rfv .ghc; cp -a $HOME/.cabsnap/ghc $HOME/.ghc; cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; else echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install --only-dependencies --enable-tests --enable-benchmarks; fi # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; then echo "snapshotting package-db to build-cache"; mkdir $HOME/.cabsnap; cp -a $HOME/.ghc $HOME/.cabsnap/ghc; cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; fi # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script: - if [ -f configure.ac ]; then autoreconf -i; fi - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests/benchmarks) - cabal test - if [ ! $CABALVER = "1.24" ]; then cabal check; fi # - cabal sdist # tests that a source-distribution can be generated # Check that the resulting source distribution can be built & installed. # If there are no other `.tar.gz` files in `dist`, this can be even simpler: # `cabal install --force-reinstalls dist/*-*.tar.gz` # - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && # (cd dist && cabal install --force-reinstalls "$SRC_TGZ") # Not included by generator - hlint src --cpp-define HLINT notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313parsers\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" # EOF parsers-0.12.4/LICENSE0000644000000000000000000000266012730064020012446 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.4/parsers.cabal0000644000000000000000000000523312730064020014103 0ustar0000000000000000name: parsers category: Text, Parsing version: 0.12.4 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: Custom 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.2, GHC==8.0.1 extra-source-files: .travis.yml source-repository head type: git location: git://github.com/ekmett/parsers.git 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 build-depends: base >= 4.3 && < 5, base-orphans >= 0.3 && < 1, charset >= 0.3 && < 1, containers >= 0.4 && < 0.6, parsec >= 3.1 && < 3.2, attoparsec >= 0.12.1.4 && < 0.14, text >= 0.10 && < 1.3, transformers >= 0.2 && < 0.6, scientific >= 0.3 && < 0.4, unordered-containers >= 0.2 && < 0.3 -- Verify the results of the examples test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs default-language: Haskell2010 build-depends: base, bytestring, containers, directory >= 1.0, doctest >= 0.9.1, filepath, QuickCheck, quickcheck-instances ghc-options: -Wall -threaded hs-source-dirs: tests test-suite quickcheck type: exitcode-stdio-1.0 main-is: QuickCheck.hs default-language: Haskell2010 build-depends: attoparsec, base == 4.*, bytestring, parsec >= 3, parsers, QuickCheck, quickcheck-instances ghc-options: -Wall -threaded hs-source-dirs: tests parsers-0.12.4/Setup.lhs0000644000000000000000000000401212730064020013242 0ustar0000000000000000#!/usr/bin/runhaskell \begin{code} {-# OPTIONS_GHC -Wall #-} module Main (main) where import Data.List ( nub ) import Data.Version ( showVersion ) import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) import Distribution.Verbosity ( Verbosity ) import System.FilePath ( () ) main :: IO () main = defaultMainWithHooks simpleUserHooks { buildHook = \pkg lbi hooks flags -> do generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi buildHook simpleUserHooks pkg lbi hooks flags } generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () generateBuildModule verbosity pkg lbi = do let dir = autogenModulesDir lbi createDirectoryIfMissingVerbose verbosity True dir withLibLBI pkg lbi $ \_ libcfg -> do withTestLBI pkg lbi $ \suite suitecfg -> do rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines [ "module Build_" ++ testName suite ++ " where" , "" , "autogen_dir :: String" , "autogen_dir = " ++ show dir , "" , "deps :: [String]" , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) ] where formatdeps = map (formatone . snd) formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p) testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys \end{code} parsers-0.12.4/src/0000755000000000000000000000000012730064020012224 5ustar0000000000000000parsers-0.12.4/src/Text/0000755000000000000000000000000012730064020013150 5ustar0000000000000000parsers-0.12.4/src/Text/Parser/0000755000000000000000000000000012730064020014404 5ustar0000000000000000parsers-0.12.4/src/Text/Parser/Char.hs0000644000000000000000000002604612730064020015625 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 qualified Text.Parsec as Parsec import qualified Data.Attoparsec.Types as Att import qualified Data.Attoparsec.Combinator as Att import Text.Parser.Combinators -- | @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) -> t n 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 #-} 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 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 #-} 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.4/src/Text/Parser/Combinators.hs0000644000000000000000000003426012730064020017225 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 , some -- from Control.Applicative, parsec many1 , many -- from Control.Applicative , sepBy , sepBy1 , sepEndBy1 , sepEndBy , endBy1 , 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) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #ifdef ORPHAN_ALTERNATIVE_READP import Data.Orphans () #endif import Data.Traversable (sequenceA) #endif import qualified Text.Parsec as Parsec import qualified Data.Attoparsec.Types as Att import qualified Data.Attoparsec.Combinator as Att import qualified Text.ParserCombinators.ReadP as ReadP -- | @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 #-} -- | @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 = (:) <$> p <*> many (sep *> p) {-# INLINE sepBy1 #-} -- | @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 = p <**> ((flip (:) <$> (sep *> sepEndBy p sep)) <|> pure 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 #-} -- | @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 -> t n a unexpected = lift . unexpected {-# INLINE unexpected #-} #endif -- | This parser only succeeds at the end of the input. This is not a -- primitive parser but it is defined using 'notFollowedBy'. -- -- > eof = notFollowedBy anyChar "end of input" eof :: m () #ifdef USE_DEFAULT_SIGNATURES default eof :: (MonadTrans t, Monad n, Parsing n, m ~ t n) => t n () 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 #-} 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 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) 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.4/src/Text/Parser/Expression.hs0000644000000000000000000001416012730064020017101 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,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops rassocOp = choice rassoc lassocOp = choice lassoc nassocOp = choice nassoc prefixOp = choice prefix "" postfixOp = choice postfix "" ambiguous assoc op = try $ op *> empty ("ambiguous use of a " ++ assoc ++ "-associative operator") ambiguousRight = ambiguous "right" rassocOp ambiguousLeft = ambiguous "left" lassocOp ambiguousNon = ambiguous "non" nassocOp termP = (prefixP <*> term) <**> postfixP postfixP = postfixOp <|> pure id 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.4/src/Text/Parser/LookAhead.hs0000644000000000000000000000656012730064020016576 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 import qualified Data.Attoparsec.Types as Att import qualified Data.Attoparsec.Combinator as Att #if __GLASGOW_HASKELL__ < 710 import Data.Monoid #endif import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.Parsec as Parsec import Text.Parser.Combinators -- | 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 #-} instance (Parsec.Stream s m t, Show t) => LookAheadParsing (Parsec.ParsecT s u m) where lookAhead = Parsec.lookAhead instance Att.Chunk i => LookAheadParsing (Att.Parser i) where lookAhead = Att.lookAhead instance LookAheadParsing ReadP.ReadP where lookAhead p = ReadP.look >>= \s -> ReadP.choice $ map (return . fst) $ ReadP.readP_to_S p s parsers-0.12.4/src/Text/Parser/Permutation.hs0000644000000000000000000001252712730064020017256 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- -- | -- 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 :: Alternative m => Permutation m a -> m a permute (Permutation def xs) = asum (map branch xs ++ e) where 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.4/src/Text/Parser/Token.hs0000644000000000000000000010115712730064020016025 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} #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 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,foldl',take,map,length,splitAt,null,transpose) import Numeric (showIntAtBase) import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.Parsec as Parsec import qualified Data.Attoparsec.Types as Att import Text.Parser.Char import Text.Parser.Combinators import Text.Parser.Token.Highlight -- | 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 :: TokenParsing m => m Char charLiteral = token (highlight CharLiteral lit) where 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 :: (TokenParsing m, IsString s) => m s stringLiteral = fromString <$> token (highlight StringLiteral lit) where lit = Prelude.foldr (maybe id (:)) "" <$> between (char '"') (char '"' "end of string") (many stringChar) "string" stringChar = Just <$> stringLetter <|> stringEscape "string character" stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) stringEscape = highlight EscapeCode $ char '\\' *> esc where esc = Nothing <$ escapeGap <|> Nothing <$ escapeEmpty <|> Just <$> escapeCode escapeEmpty = char '&' escapeGap = skipSome space *> (char '\\' "end of string gap") {-# INLINE stringLiteral #-} -- | This token parser behaves as 'stringLiteral', but for single-quoted -- strings. stringLiteral' :: (TokenParsing m, IsString s) => m s stringLiteral' = fromString <$> token (highlight StringLiteral lit) where lit = Prelude.foldr (maybe id (:)) "" <$> between (char '\'') (char '\'' "end of string") (many stringChar) "string" stringChar = Just <$> stringLetter <|> stringEscape "string character" stringLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) stringEscape = highlight EscapeCode $ char '\\' *> esc where esc = Nothing <$ escapeGap <|> Nothing <$ escapeEmpty <|> Just <$> escapeCode escapeEmpty = char '&' escapeGap = skipSome space *> (char '\\' "end of string gap") {-# INLINE stringLiteral' #-} -- | This token parser parses a natural number (a positive 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 :: TokenParsing m => m Integer integer = token (token (highlight Operator sgn <*> natural')) "integer" where 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 :: TokenParsing m => m (Either Integer Scientific) integerOrScientific = token (highlight Number ios "number") where 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 :: TokenParsing m => m Char escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) "escape code" where charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (char '^' *> (upper <|> char '@')) charNum = toEnum <$> num where num = bounded 10 maxchar <|> (char 'o' *> bounded 8 maxchar) <|> (char 'x' *> bounded 16 maxchar) maxchar = fromEnum (maxBound :: Char) bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0 <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "") where thedigits = map char ['0'..'9'] ++ map oneOf (transpose [['A'..'F'],['a'..'f']]) toomuch = unexpected "out-of-range numeric escape sequence" 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 = choice dps 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 = choice $ parseEsc <$> escMap parseEsc (c,code) = code <$ char c escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" 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 positive 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 :: 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 = foldl' op 0 <$> (char '.' *> (some digit "fraction")) op f d = f + Sci.scientific (fromIntegral (digitToInt d)) (Sci.base10Exponent f - 1) 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 positive 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 positive 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 positive 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 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 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 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 #-} instance Parsec.Stream s m Char => TokenParsing (Parsec.ParsecT s u m) instance Att.Chunk t => TokenParsing (Att.Parser t) instance TokenParsing ReadP.ReadP parsers-0.12.4/src/Text/Parser/Token/0000755000000000000000000000000012730064020015464 5ustar0000000000000000parsers-0.12.4/src/Text/Parser/Token/Highlight.hs0000644000000000000000000000237312730064020017734 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.4/src/Text/Parser/Token/Style.hs0000644000000000000000000001543312730064020017126 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} #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 :: 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 = 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 = () <$ 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.4/tests/0000755000000000000000000000000012730064020012577 5ustar0000000000000000parsers-0.12.4/tests/doctests.hs0000644000000000000000000000155012730064020014764 0ustar0000000000000000module Main where import Build_doctests (autogen_dir, deps) import Control.Applicative import Control.Monad import Data.List import System.Directory import System.FilePath import Test.DocTest main :: IO () main = getSources >>= \sources -> doctest $ "-isrc" : ("-i" ++ autogen_dir) : "-optP-include" : ("-optP" ++ autogen_dir ++ "/cabal_macros.h") : "-hide-all-packages" : map ("-package="++) deps ++ sources getSources :: IO [FilePath] getSources = filter (isSuffixOf ".hs") <$> go "src" where go dir = do (dirs, files) <- getFilesAndDirectories dir (files ++) . concat <$> mapM go dirs getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) getFilesAndDirectories dir = do c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c parsers-0.12.4/tests/QuickCheck.hs0000644000000000000000000000575312730064020015157 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Main ( main ) where import Control.Applicative import Data.Attoparsec.ByteString.Char8 (parseOnly) import qualified Data.ByteString.Char8 as B8 #if MIN_VERSION_base(4,7,0) import Data.Either #endif import Test.QuickCheck import Test.QuickCheck.Instances () import Text.Parsec.Prim as P (parse) 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. data 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 pAtto, pParsec, pReadP :: TestParser a pAtto = TestParser "attoparsec" $ \(P p) -> parseOnly p . B8.pack pParsec = TestParser "parsec" $ \(P p) -> either (Left . show) Right . parse p "test input" 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 [pReadP, pAtto, pParsec] -- -------------------------------------------------------------------------- -- -- 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