packages feed

parsers 0.3.2 → 0.4

raw patch · 18 files changed

+1980/−1621 lines, 18 filesdep +directorydep +doctestdep +filepathdep ~basedep ~charsetdep ~containersbuild-type:Customsetup-changed

Dependencies added: directory, doctest, filepath

Dependency ranges changed: base, charset, containers

Files

.travis.yml view
@@ -1,1 +1,28 @@ language: haskell+before_install:+  # Uncomment whenever hackage is down.+  # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update++  # Try installing some of the build-deps with apt-get for speed.+  - travis/cabal-apt-install --only-dependencies --force-reinstall $mode++  - sudo apt-get -q -y install hlint || cabal install hlint++install:+  - cabal configure -flib-Werror $mode+  - cabal build++script:+  - $script+  - hlint src --cpp-define HLINT++notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313parsers\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"++env:+  - mode="--enable-tests" script="cabal test"
Setup.lhs view
@@ -1,7 +1,44 @@ #!/usr/bin/runhaskell-> module Main (main) where+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where -> import Distribution.Simple+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 = defaultMain+main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
− Text/Parser/Char.hs 
@@ -1,256 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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-  -- * Class-  , CharParsing(..)-  ) where--import Control.Applicative-import Control.Monad.Trans.Class-import Control.Monad.Trans.State.Lazy as Lazy-import Control.Monad.Trans.State.Strict as Strict-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-import Data.Monoid-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 #-}---- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current--- character /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 #-}---- | @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 /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' and--- 'whiteSpace'.-spaces :: CharParsing m => m ()-spaces = skipMany space <?> "white space"---- | 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 (a character between \'A\' and \'Z\').--- Returns the parsed character.-upper :: CharParsing m => m Char-upper = satisfy isUpper <?> "uppercase letter"-{-# INLINE upper #-}---- | Parses a lower case character (a character between \'a\' and \'z\').--- Returns the parsed character.-lower :: CharParsing m => m Char-lower = satisfy isLower <?> "lowercase letter"-{-# INLINE lower #-}---- | Parses a letter or digit (a character between \'0\' and \'9\').--- 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 #-}---- | 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@).-  ---  -- >  semiColon  = char ';'-  char :: CharParsing m => Char -> m Char-  char c = satisfy (c ==) <?> show [c]--  -- | @notChar c@ parses any single character other than @c@. Returns the parsed-  -- character.-  ---  -- >  semiColon  = char ';'-  notChar :: CharParsing m => Char -> m Char-  notChar c = satisfy (c /=)--  -- | This parser succeeds for any character. Returns the parsed character.-  anyChar :: CharParsing m => m Char-  anyChar = satisfy (const True)--  -- | @string s@ parses a sequence of characters given by @s@. Returns-  -- the parsed string (i.e. @s@).-  ---  -- >  divOrMod    =   string "div"-  -- >              <|> string "mod"-  string :: CharParsing m => String -> m String-  string s = s <$ try (traverse_ char s) <?> show s---instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where-  satisfy = lift . satisfy-  char    = lift . char-  notChar = lift . notChar-  anyChar = lift anyChar-  string  = lift . string--instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where-  satisfy = lift . satisfy-  char    = lift . char-  notChar = lift . notChar-  anyChar = lift anyChar-  string  = lift . string--instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where-  satisfy = lift . satisfy-  char    = lift . char-  notChar = lift . notChar-  anyChar = lift anyChar-  string  = lift . string--instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where-  satisfy = lift . satisfy-  char    = lift . char-  notChar = lift . notChar-  anyChar = lift anyChar-  string  = lift . string--instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where-  satisfy = lift . satisfy-  char    = lift . char-  notChar = lift . notChar-  anyChar = lift anyChar-  string  = lift . string--instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where-  satisfy = lift . satisfy-  char    = lift . char-  notChar = lift . notChar-  anyChar = lift anyChar-  string  = lift . string--instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where-  satisfy = lift . satisfy-  char    = lift . char-  notChar = lift . notChar-  anyChar = lift anyChar-  string  = lift . string--instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where-  satisfy = lift . satisfy-  char    = lift . char-  notChar = lift . notChar-  anyChar = lift anyChar-  string  = lift . string-
− Text/Parser/Combinators.hs 
@@ -1,319 +0,0 @@-{-# LANGUAGE CPP #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704-#define USE_DEFAULT_SIGNATURES-#endif--#ifdef USE_DEFAULT_SIGNATURES-{-# LANGUAGE DefaultSignatures, TypeFamilies #-}-#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 Data.Traversable (sequenceA)-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.Monoid---- | @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 = foldr (<|>) empty-{-# 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 = flip id <$> 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@, seperated--- and ended by @sep@. Returns a list of values returned by @p@.-endBy1 :: Alternative m => m a -> m sep -> m [a]-endBy1 p sep = some (p <* sep)-{-# INLINE endBy1 #-}---- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated--- 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@ parser /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@ parser /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@ parser /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 = flip id <$> p <*> rst-  rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id-{-# INLINE chainl1 #-}---- | @chainr1 p op x@ parser /one/ or more occurrences of |p|,--- separated by @op@ Returns a value obtained by a /right/ associative--- application of all functions returned by @op@ to the values returned--- by @p@.-chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a-chainr1 p op = scan where-  scan = flip id <$> p <*> rst-  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 "<!--"--- >                      ; manyTill anyChar (try (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--  -- | @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--  -- | @lookAhead p@ parses @p@ without consuming any input.-  lookAhead :: m a -> m a--  -- | 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-#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-#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 :: (Monad m, Show a) => m a -> m ()-  notFollowedBy p = try ((try p >>= unexpected . show) <|> pure ())--instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where-  try (Lazy.StateT m) = Lazy.StateT $ try . m-  Lazy.StateT m <?> l = Lazy.StateT $ \s -> m s <?> l-  lookAhead (Lazy.StateT m) = Lazy.StateT $ lookAhead . m-  unexpected = lift . unexpected-  eof = lift eof--instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where-  try (Strict.StateT m) = Strict.StateT $ try . m-  Strict.StateT m <?> l = Strict.StateT $ \s -> m s <?> l-  lookAhead (Strict.StateT m) = Strict.StateT $ lookAhead . m-  unexpected = lift . unexpected-  eof = lift eof--instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where-  try (ReaderT m) = ReaderT $ try . m-  ReaderT m <?> l = ReaderT $ \e -> m e <?> l-  skipMany (ReaderT m) = ReaderT $ skipMany . m-  lookAhead (ReaderT m) = ReaderT $ lookAhead . m-  unexpected = lift . unexpected-  eof = lift eof--instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where-  try (Strict.WriterT m) = Strict.WriterT $ try m-  Strict.WriterT m <?> l = Strict.WriterT (m <?> l)-  lookAhead (Strict.WriterT m) = Strict.WriterT $ lookAhead m-  unexpected = lift . unexpected-  eof = lift eof--instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where-  try (Lazy.WriterT m) = Lazy.WriterT $ try m-  Lazy.WriterT m <?> l = Lazy.WriterT (m <?> l)-  lookAhead (Lazy.WriterT m) = Lazy.WriterT $ lookAhead m-  unexpected = lift . unexpected-  eof = lift eof--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)-  Lazy.RWST m <?> l = Lazy.RWST $ \r s -> m r s <?> l-  lookAhead (Lazy.RWST m) = Lazy.RWST $ \r s -> lookAhead (m r s)-  unexpected = lift . unexpected-  eof = lift eof--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)-  Strict.RWST m <?> l = Strict.RWST $ \r s -> m r s <?> l-  lookAhead (Strict.RWST m) = Strict.RWST $ \r s -> lookAhead (m r s)-  unexpected = lift . unexpected-  eof = lift eof--instance (Parsing m, Monad m) => Parsing (IdentityT m) where-  try = IdentityT . try . runIdentityT-  IdentityT m <?> l = IdentityT (m <?> l)-  skipMany = IdentityT . skipMany . runIdentityT-  lookAhead = IdentityT . lookAhead . runIdentityT-  unexpected = lift . unexpected-  eof = lift eof
− Text/Parser/Expression.hs 
@@ -1,168 +0,0 @@--------------------------------------------------------------------------------- |--- 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---------------------------------------------------------------- Assoc and OperatorTable---------------------------------------------------------------- |  This data type specifies the associativity of operators: left, right--- or none.--data Assoc-  = AssocNone-  | AssocLeft-  | AssocRight---- | 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.------ >  expr    = buildExpressionParser table term--- >          <?> "expression"--- >--- >  term    =  parens expr--- >          <|> natural--- >          <?> "simple expression"--- >--- >  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)--buildExpressionParser :: (Parsing m, Monad 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 <?> ""--              ambigious assoc op= try $ op *> fail ("ambiguous use of a " ++ assoc ++ " associative operator")--              ambigiousRight    = ambigious "right" rassocOp-              ambigiousLeft     = ambigious "left" lassocOp-              ambigiousNon      = ambigious "non" nassocOp--              preTermP   =     do { pre <- prefixP; x <- term; return $ pre x }-                           <|> term--              termP      = do { x <- preTermP-                              ; post <- postfixP-                              ; return (post x)-                              }--              postfixP   = postfixOp <|> return id--              prefixP    = prefixOp <|> return id--              rassocP x  = do{ f <- rassocOp-                             ; y <- termP >>= rassocP1-                             ; return (f x y)-                             }-                           <|> ambigiousLeft-                           <|> ambigiousNon-                           -- <|> return x--              rassocP1 x = rassocP x <|> return x--              lassocP x  = do{ f <- lassocOp-                             ; y <- termP-                             ; lassocP1 (f x y)-                             }-                           <|> ambigiousRight-                           <|> ambigiousNon-                           -- <|> return x--              lassocP1 x = lassocP x <|> return x--              nassocP x  = do{ f <- nassocOp-                             ; y <- termP-                             ;    ambigiousRight-                              <|> ambigiousLeft-                              <|> ambigiousNon-                              <|> return (f x y)-                             }-                           -- <|> return x--           in  do{ x <- termP-                 ; rassocP x <|> lassocP  x <|> nassocP x <|> return x-                   <?> "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)
− Text/Parser/Permutation.hs 
@@ -1,140 +0,0 @@--------------------------------------------------------------------------------- |--- 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.-----------------------------------------------------------------------------------{-# LANGUAGE ExistentialQuantification #-}--module Text.Parser.Permutation-    ( Permutation-    , permute-    , (<||>), (<$$>)-    , (<|?>), (<$?>)-    ) where--import Control.Applicative--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---- | The expression @f \<$$> p@ creates a fresh permutation parser--- consisting of parser @p@. The 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---- | 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---- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser--- consisting of parser @p@. The 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)--------------------------------------------------------------------- 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)-  = foldr (<|>) empty (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) []--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'
− Text/Parser/Token.hs 
@@ -1,540 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# 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    = haskellIdentifierStyle { styleReserved = ... }--- > identifier = ident haskellIdentifierStyle--- > reserved   = reserve haskellIdentifierStyle----------------------------------------------------------------------------------module Text.Parser.Token-  (-  -- * Token Parsing-    whiteSpace      -- :: TokenParsing m => m ()-  , token           -- :: TokenParsing m => m a -> m a-  , charLiteral     -- :: TokenParsing m => m Char-  , stringLiteral   -- :: TokenParsing m => m String-  , natural         -- :: TokenParsing m => m Integer-  , integer         -- :: TokenParsing m => m Integer-  , double          -- :: TokenParsing m => m Double-  , naturalOrDouble -- :: TokenParsing m => m (Either Integer Double)-  , symbol          -- :: TokenParsing m => String -> m String-  , 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(..)-  , 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 => IdentifierStyle m -> m String-  , reserve         -- :: TokenParsing m => IdentifierStyle m -> String -> m ()-  ) 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 qualified Data.HashSet as HashSet-import Data.HashSet (HashSet)-import Data.List (foldl')-import Data.Monoid-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 #-}---- | @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.------ > mainParser  = sum <$ whiteSpace <*> many (token digit) <* eof-token :: TokenParsing m => m a -> m a-token p = p <* whiteSpace-{-# INLINE token #-}---- | 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 => m String-stringLiteral = 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 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 = token (highlight Number natDouble <?> "number")-{-# INLINE naturalOrDouble #-}---- | 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 @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 = sepBy 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)--  -- | Called when we enter a nested pair of symbols.-  -- Overloadable to enable disabling layout-  nesting :: m a -> m a-  nesting = id--  -- | 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 = (satisfy (';'==) <?> ";") <* (someSpace <|> pure ())--  -- | 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--instance (TokenParsing m, MonadPlus m) => TokenParsing (Lazy.StateT s m) where-  nesting (Lazy.StateT m) = Lazy.StateT $ nesting . m-  someSpace = lift someSpace-  semi      = lift semi-  highlight h (Lazy.StateT m) = Lazy.StateT $ highlight h . m--instance (TokenParsing m, MonadPlus m) => TokenParsing (Strict.StateT s m) where-  nesting (Strict.StateT m) = Strict.StateT $ nesting . m-  someSpace = lift someSpace-  semi      = lift semi-  highlight h (Strict.StateT m) = Strict.StateT $ highlight h . m--instance (TokenParsing m, MonadPlus m) => TokenParsing (ReaderT e m) where-  nesting (ReaderT m) = ReaderT $ nesting . m-  someSpace = lift someSpace-  semi      = lift semi-  highlight h (ReaderT m) = ReaderT $ highlight h . m--instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Strict.WriterT w m) where-  nesting (Strict.WriterT m) = Strict.WriterT $ nesting m-  someSpace = lift someSpace-  semi      = lift semi-  highlight h (Strict.WriterT m) = Strict.WriterT $ highlight h m--instance (TokenParsing m, MonadPlus m, Monoid w) => TokenParsing (Lazy.WriterT w m) where-  nesting (Lazy.WriterT m) = Lazy.WriterT $ nesting m-  someSpace = lift someSpace-  semi      = lift semi-  highlight h (Lazy.WriterT m) = Lazy.WriterT $ highlight h m--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)-  someSpace = lift someSpace-  semi      = lift semi-  highlight h (Lazy.RWST m) = Lazy.RWST $ \r s -> highlight h (m r s)--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)-  someSpace = lift someSpace-  semi      = lift semi-  highlight h (Strict.RWST m) = Strict.RWST $ \r s -> highlight h (m r s)--instance (TokenParsing m, MonadPlus m) => TokenParsing (IdentityT m) where-  nesting = IdentityT . nesting . runIdentityT-  someSpace = lift someSpace-  semi      = lift semi-  highlight h = IdentityT . highlight h . runIdentityT---- | 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-  }---- | Lift an identifier style into a monad transformer-liftIdentifierStyle :: (MonadTrans t, Monad m) => IdentifierStyle m -> IdentifierStyle (t m)-liftIdentifierStyle s =-  s { styleStart  = lift (styleStart s)-    , styleLetter = lift (styleLetter s)-    }-{-# 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 an non-reserved identifier or symbol-ident :: (TokenParsing m, Monad m) => IdentifierStyle m -> m String-ident s = 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 'A')) <$> (char '^' *> upper)-  charNum     = toEnum . fromInteger <$> num where-    num = decimal-      <|> (char 'o' *> number 8 octDigit)-      <|> (char 'x' *> number 16 hexDigit)-  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 :: [Char]-  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 Double-floating = decimal <**> fractExponent-{-# INLINE floating #-}--fractExponent :: TokenParsing m => m (Integer -> Double)-fractExponent = (\fract expo n -> (fromInteger n + fract) * expo) <$> fraction <*> option 1.0 exponent'-            <|> (\expo n -> fromInteger n * expo) <$> exponent' where-  fraction = Prelude.foldr op 0.0 <$> (char '.' *> (some digit <?> "fraction"))-  op d f = (f + fromIntegral (digitToInt d))/10.0-  exponent' = ((\f e -> power (f e)) <$ oneOf "eE" <*> sign <*> (decimal <?> "exponent")) <?> "exponent"-  power e-    | e < 0     = 1.0/power(-e)-    | otherwise = fromInteger (10^e)--natDouble, zeroNumFloat, decimalFloat :: TokenParsing m => m (Either Integer Double)-natDouble-    = char '0' *> zeroNumFloat-  <|> decimalFloat-zeroNumFloat-    = Left <$> (hexadecimal <|> octal)-  <|> decimalFloat-  <|> pure 0 <**> fractFloat-  <|> pure (Left 0)-decimalFloat = decimal <**> option Left (try fractFloat)--fractFloat :: TokenParsing m => m (Integer -> Either Integer Double)-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,Parsing,CharParsing)--instance MonadTrans Unhighlighted where-  lift = Unhighlighted--instance (TokenParsing m, MonadPlus m) => TokenParsing (Unhighlighted m) where-  nesting (Unhighlighted m) = Unhighlighted (nesting m)-  someSpace = lift someSpace-  semi      = lift semi-  highlight _ m = m---- | 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,Parsing,CharParsing)--instance MonadTrans Unspaced where-  lift = Unspaced--instance (TokenParsing m, MonadPlus m) => TokenParsing (Unspaced m) where-  nesting (Unspaced m) = Unspaced (nesting m)-  someSpace = empty-  semi      = lift semi-  highlight h (Unspaced m) = Unspaced (highlight h m)
− Text/Parser/Token/Highlight.hs 
@@ -1,46 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Parser.Token.Highlight--- Copyright   :  (C) 2011 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- 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)
− Text/Parser/Token/Style.hs 
@@ -1,137 +0,0 @@--------------------------------------------------------------------------------- |--- 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(..)-  , emptyCommentStyle-  , javaCommentStyle-  , 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)-import Data.Monoid-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?-  }---- | No comments at all-emptyCommentStyle :: CommentStyle-emptyCommentStyle   = CommentStyle "" "" "" True---- | Use java-style comments-javaCommentStyle :: CommentStyle-javaCommentStyle = 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.cabal view
@@ -1,8 +1,8 @@ name:          parsers category:      Text, Parsing-version:       0.3.2+version:       0.4 license:       BSD3-cabal-version: >= 1.6+cabal-version: >= 1.10 license-file:  LICENSE author:        Edward A. Kmett maintainer:    Edward A. Kmett <ekmett@gmail.com>@@ -12,7 +12,7 @@ copyright:     Copyright (C) 2010-2012 Edward A. Kmett synopsis:      Parsing combinators description:   Parsing combinators-build-type:    Simple+build-type:    Custom  extra-source-files: .travis.yml @@ -20,7 +20,12 @@   type: git   location: git://github.com/ekmett/parsers.git +flag lib-Werror+  manual: True+  default: False+ library+  default-language: Haskell2010   exposed-modules:     Text.Parser.Char     Text.Parser.Combinators@@ -30,18 +35,34 @@     Text.Parser.Token.Style     Text.Parser.Token.Highlight -  ghc-options: -Wall+  hs-source-dirs: src +  if flag(lib-Werror)+    ghc-options: -Wall+  else+    ghc-options: -Wall++  ghc-options: -O2+   build-depends:     base                 >= 4       && < 5,-    charset              >= 0.3     && < 0.4,+    charset              >= 0.3,     containers           >= 0.4     && < 0.6,     transformers         >= 0.2     && < 0.4,     unordered-containers >= 0.2     && < 0.3 -  other-extensions: CPP, ExistentialQuantification--  -- Cabal doesn't understand DefaultSignatures--  -- if impl(ghc >= 7.4)-  --   other-extensions: DefaultSignatures, TypeFamilies+-- Verify the results of the examples+test-suite doctests+  type:    exitcode-stdio-1.0+  main-is: doctests.hs+  default-language: Haskell2010+  build-depends:+    base,+    containers,+    directory >= 1.0,+    doctest >= 0.9.1,+    filepath+  ghc-options: -Wall -threaded+  if impl(ghc<7.6.1)+    ghc-options: -Werror+  hs-source-dirs: tests
+ src/Text/Parser/Char.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE CPP #-}+{-# 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+  -- * Class+  , CharParsing(..)+  ) where++import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Lazy as Lazy+import Control.Monad.Trans.State.Strict as Strict+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+import Data.Monoid+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 /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 /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' and+-- 'whiteSpace'.+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 (a character between \'A\' and \'Z\').+-- Returns the parsed character.+upper :: CharParsing m => m Char+upper = satisfy isUpper <?> "uppercase letter"+{-# INLINE upper #-}++-- | Parses a lower case character (a character between \'a\' and \'z\').+-- Returns the parsed character.+lower :: CharParsing m => m Char+lower = satisfy isLower <?> "lowercase letter"+{-# INLINE lower #-}++-- | Parses a letter or digit (a character between \'0\' and \'9\').+-- 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 #-}++-- | 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 :: CharParsing m => 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 :: CharParsing m => Char -> m Char+  notChar c = satisfy (c /=)+  {-# INLINE notChar #-}++  -- | This parser succeeds for any character. Returns the parsed character.+  anyChar :: CharParsing m => 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 :: CharParsing m => String -> m String+  string s = s <$ try (traverse_ char s) <?> show s+  {-# INLINE string #-}+++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 #-}++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 #-}++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 #-}++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 #-}++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 #-}++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 #-}++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 #-}++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 #-}
+ src/Text/Parser/Combinators.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE CPP #-}++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704+#define USE_DEFAULT_SIGNATURES+#endif++#ifdef USE_DEFAULT_SIGNATURES+{-# LANGUAGE DefaultSignatures, TypeFamilies #-}+#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)+import Data.Monoid+import Data.Traversable (sequenceA)++-- | @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 = flip id <$> 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@, seperated+-- and ended by @sep@. Returns a list of values returned by @p@.+endBy1 :: Alternative m => m a -> m sep -> m [a]+endBy1 p sep = some (p <* sep)+{-# INLINE endBy1 #-}++-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated+-- 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@ parser /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@ parser /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@ parser /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 = flip id <$> p <*> rst+  rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id+{-# INLINE chainl1 #-}++-- | @chainr1 p op x@ parser /one/ or more occurrences of |p|,+-- separated by @op@ Returns a value obtained by a /right/ associative+-- application of all functions returned by @op@ to the values returned+-- by @p@.+chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a+chainr1 p op = scan where+  scan = flip id <$> p <*> rst+  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 "<!--"+-- >                      ; manyTill anyChar (try (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 #-}++  -- | @lookAhead p@ parses @p@ without consuming any input.+  lookAhead :: m a -> m a++  -- | 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 :: (Monad m, Show a) => m a -> m ()+  notFollowedBy p = try ((try p >>= unexpected . show) <|> pure ())+  {-# INLINE notFollowedBy #-}++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 (<?>) #-}+  lookAhead (Lazy.StateT m) = Lazy.StateT $ lookAhead . m+  {-# INLINE lookAhead #-}+  unexpected = lift . unexpected+  {-# INLINE unexpected #-}+  eof = lift eof+  {-# INLINE eof #-}++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 (<?>) #-}+  lookAhead (Strict.StateT m) = Strict.StateT $ lookAhead . m+  {-# INLINE lookAhead #-}+  unexpected = lift . unexpected+  {-# INLINE unexpected #-}+  eof = lift eof+  {-# INLINE eof #-}++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 #-}+  lookAhead (ReaderT m) = ReaderT $ lookAhead . m+  {-# INLINE lookAhead #-}+  unexpected = lift . unexpected+  {-# INLINE unexpected #-}+  eof = lift eof+  {-# INLINE eof #-}++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 (<?>) #-}+  lookAhead (Strict.WriterT m) = Strict.WriterT $ lookAhead m+  {-# INLINE lookAhead #-}+  unexpected = lift . unexpected+  {-# INLINE unexpected #-}+  eof = lift eof+  {-# INLINE eof #-}++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 (<?>) #-}+  lookAhead (Lazy.WriterT m) = Lazy.WriterT $ lookAhead m+  {-# INLINE lookAhead #-}+  unexpected = lift . unexpected+  {-# INLINE unexpected #-}+  eof = lift eof+  {-# INLINE eof #-}++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 (<?>) #-}+  lookAhead (Lazy.RWST m) = Lazy.RWST $ \r s -> lookAhead (m r s)+  {-# INLINE lookAhead #-}+  unexpected = lift . unexpected+  {-# INLINE unexpected #-}+  eof = lift eof+  {-# INLINE eof #-}++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 (<?>) #-}+  lookAhead (Strict.RWST m) = Strict.RWST $ \r s -> lookAhead (m r s)+  {-# INLINE lookAhead #-}+  unexpected = lift . unexpected+  {-# INLINE unexpected #-}+  eof = lift eof+  {-# INLINE eof #-}++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 #-}+  lookAhead = IdentityT . lookAhead . runIdentityT+  {-# INLINE lookAhead #-}+  unexpected = lift . unexpected+  {-# INLINE unexpected #-}+  eof = lift eof+  {-# INLINE eof #-}
+ src/Text/Parser/Expression.hs view
@@ -0,0 +1,168 @@+-----------------------------------------------------------------------------+-- |+-- 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++-----------------------------------------------------------+-- Assoc and OperatorTable+-----------------------------------------------------------++-- |  This data type specifies the associativity of operators: left, right+-- or none.++data Assoc+  = AssocNone+  | AssocLeft+  | AssocRight++-- | 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.+--+-- >  expr    = buildExpressionParser table term+-- >          <?> "expression"+-- >+-- >  term    =  parens expr+-- >          <|> natural+-- >          <?> "simple expression"+-- >+-- >  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)++buildExpressionParser :: (Parsing m, Monad 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 *> fail ("ambiguous use of a " ++ assoc ++ " associative operator")++              ambiguousRight    = ambiguous "right" rassocOp+              ambiguousLeft     = ambiguous "left" lassocOp+              ambiguousNon      = ambiguous "non" nassocOp++              preTermP   =     do { pre <- prefixP; x <- term; return $ pre x }+                           <|> term++              termP      = do { x <- preTermP+                              ; post <- postfixP+                              ; return (post x)+                              }++              postfixP   = postfixOp <|> return id++              prefixP    = prefixOp <|> return id++              rassocP x  = do{ f <- rassocOp+                             ; y <- termP >>= rassocP1+                             ; return (f x y)+                             }+                           <|> ambiguousLeft+                           <|> ambiguousNon+                           -- <|> return x++              rassocP1 x = rassocP x <|> return x++              lassocP x  = do{ f <- lassocOp+                             ; y <- termP+                             ; lassocP1 (f x y)+                             }+                           <|> ambiguousRight+                           <|> ambiguousNon+                           -- <|> return x++              lassocP1 x = lassocP x <|> return x++              nassocP x  = do{ f <- nassocOp+                             ; y <- termP+                             ;    ambiguousRight+                              <|> ambiguousLeft+                              <|> ambiguousNon+                              <|> return (f x y)+                             }+                           -- <|> return x++           in  do{ x <- termP+                 ; rassocP x <|> lassocP  x <|> nassocP x <|> return x+                   <?> "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)
+ src/Text/Parser/Permutation.hs view
@@ -0,0 +1,146 @@+-----------------------------------------------------------------------------+-- |+-- 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.+--+-----------------------------------------------------------------------------++{-# LANGUAGE ExistentialQuantification #-}++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 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 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'
+ src/Text/Parser/Token.hs view
@@ -0,0 +1,650 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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    = haskellIdentifierStyle { styleReserved = ... }+-- > identifier = ident haskellIdentifierStyle+-- > reserved   = reserve haskellIdentifierStyle+--+-----------------------------------------------------------------------------+module Text.Parser.Token+  (+  -- * Token Parsing+    whiteSpace      -- :: TokenParsing m => m ()+  , token           -- :: TokenParsing m => m a -> m a+  , charLiteral     -- :: TokenParsing m => m Char+  , stringLiteral   -- :: TokenParsing m => m String+  , natural         -- :: TokenParsing m => m Integer+  , integer         -- :: TokenParsing m => m Integer+  , double          -- :: TokenParsing m => m Double+  , naturalOrDouble -- :: TokenParsing m => m (Either Integer Double)+  , symbol          -- :: TokenParsing m => String -> m String+  , 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(..)+  , 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 => IdentifierStyle m -> m String+  , reserve         -- :: TokenParsing m => IdentifierStyle m -> String -> 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')+import Data.Monoid+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 #-}++-- | @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.+--+-- > mainParser  = sum <$ whiteSpace <*> many (token digit) <* eof+token :: TokenParsing m => m a -> m a+token p = p <* whiteSpace+{-# INLINE token #-}++-- | 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 => m String+stringLiteral = 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 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 = token (highlight Number natDouble <?> "number")+{-# INLINE naturalOrDouble #-}++-- | 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 @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 = sepBy 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 = (satisfy (';'==) <?> ";") <* (someSpace <|> pure ())+  {-# 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 #-}++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 an non-reserved identifier or symbol+ident :: (TokenParsing m, Monad m) => IdentifierStyle m -> m String+ident s = 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 'A')) <$> (char '^' *> upper)+  charNum     = toEnum . fromInteger <$> num where+    num = decimal+      <|> (char 'o' *> number 8 octDigit)+      <|> (char 'x' *> number 16 hexDigit)+  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 Double+floating = decimal <**> fractExponent+{-# INLINE floating #-}++fractExponent :: TokenParsing m => m (Integer -> Double)+fractExponent = (\fract expo n -> (fromInteger n + fract) * expo) <$> fraction <*> option 1.0 exponent'+            <|> (\expo n -> fromInteger n * expo) <$> exponent' where+  fraction = Prelude.foldr op 0.0 <$> (char '.' *> (some digit <?> "fraction"))+  op d f = (f + fromIntegral (digitToInt d))/10.0+  exponent' = ((\f e -> power (f e)) <$ oneOf "eE" <*> sign <*> (decimal <?> "exponent")) <?> "exponent"+  power e+    | e < 0     = 1.0/power(-e)+    | otherwise = fromInteger (10^e)++natDouble, zeroNumFloat, decimalFloat :: TokenParsing m => m (Either Integer Double)+natDouble+    = char '0' *> zeroNumFloat+  <|> decimalFloat+zeroNumFloat+    = Left <$> (hexadecimal <|> octal)+  <|> decimalFloat+  <|> pure 0 <**> fractFloat+  <|> pure (Left 0)+decimalFloat = decimal <**> option Left (try fractFloat)++fractFloat :: TokenParsing m => m (Integer -> Either Integer Double)+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,Parsing,CharParsing)++instance MonadTrans Unhighlighted where+  lift = Unhighlighted+  {-# INLINE lift #-}++instance (TokenParsing m, MonadPlus m) => TokenParsing (Unhighlighted m) where+  nesting (Unhighlighted m) = Unhighlighted (nesting m)+  {-# INLINE nesting #-}+  someSpace = lift someSpace+  {-# INLINE someSpace #-}+  semi      = lift 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,Parsing,CharParsing)++instance MonadTrans Unspaced where+  lift = Unspaced+  {-# INLINE lift #-}++instance (TokenParsing m, MonadPlus m) => TokenParsing (Unspaced m) where+  nesting (Unspaced m) = Unspaced (nesting m)+  {-# INLINE nesting #-}+  someSpace = empty+  {-# INLINE someSpace #-}+  semi      = lift semi+  {-# INLINE semi #-}+  highlight h (Unspaced m) = Unspaced (highlight h m)+  {-# INLINE highlight #-}
+ src/Text/Parser/Token/Highlight.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parser.Token.Highlight+-- Copyright   :  (C) 2011 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- 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)
+ src/Text/Parser/Token/Style.hs view
@@ -0,0 +1,171 @@+-----------------------------------------------------------------------------+-- |+-- 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+  , 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)+import Data.Monoid+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?+  }++-- | 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 "/*" "*/" "//" 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"+  ]
+ tests/doctests.hs view
@@ -0,0 +1,30 @@+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++main :: IO ()+main = getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : "-hide-all-packages"+  : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c