packages feed

parsers (empty) → 0.1

raw patch · 10 files changed

+1583/−0 lines, 10 filesdep +basedep +charsetdep +containerssetup-changed

Dependencies added: base, charset, containers, transformers, unordered-containers

Files

+ .travis.yml view
@@ -0,0 +1,1 @@+language: haskell
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2011-2012 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ Text/Parser/Char.hs view
@@ -0,0 +1,451 @@+{-# 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+--                (c) Daan Leijen 1999-2001+-- License     :  BSD3+--+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Parsers for character streams+--+-----------------------------------------------------------------------------+module Text.Parser.Char+  ( CharParsing(..)+  -- * Character parsers+  , 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+  , decimal     -- :: CharParsing m => m Integer+  , hexadecimal -- :: CharParsing m => m Integer+  , octal       -- :: CharParsing m => m Integer+  -- ** Internal parsers+  , charLiteral'+  , characterChar+  , stringLiteral'+  , natural'+  , integer'+  , double'+  , naturalOrDouble'+  ) 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 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 #-}++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, 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 => CharParsing (Lazy.StateT s m) where+  satisfy = lift . satisfy+  char    = lift . char+  notChar = lift . notChar+  anyChar = lift anyChar+  string  = lift . string++instance CharParsing 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 => CharParsing (ReaderT e m) where+  satisfy = lift . satisfy+  char    = lift . char+  notChar = lift . notChar+  anyChar = lift anyChar+  string  = lift . string++instance (CharParsing 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, 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, 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, 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 => CharParsing (IdentityT m) where+  satisfy = lift . satisfy+  char    = lift . char+  notChar = lift . notChar+  anyChar = lift anyChar+  string  = lift . string+++-- | This 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).+--+-- This parser does NOT swallow trailing whitespace.+charLiteral' :: CharParsing m => m Char+charLiteral' = between (char '\'') (char '\'' <?> "end of character") characterChar+          <?> "character"++characterChar, charEscape, charLetter :: CharParsing m => m Char+characterChar = charLetter <|> charEscape+            <?> "literal character"+charEscape = char '\\' *> escapeCode+charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))++-- | 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+stringLiteral' :: CharParsing m => m String+stringLiteral' = Prelude.foldr (maybe id (:)) "" <$>+  between (char '"') (char '"' <?> "end of string") (many stringChar) <?> +  "literal string" where+  stringChar = Just <$> stringLetter+           <|> stringEscape+       <?> "string character"+  stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++  stringEscape = char '\\' *> esc where+    esc = Nothing <$ escapeGap+      <|> Nothing <$ escapeEmpty+      <|> Just <$> escapeCode+  escapeEmpty = char '&'+  escapeGap = do skipSome space+                 char '\\' <?> "end of string gap"++escapeCode :: CharParsing 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' :: CharParsing m => m Integer+natural' = nat <?> "natural"++number :: CharParsing m => Integer -> m Char -> m Integer+number base baseDigit = do+  digits <- some baseDigit+  return $! foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 digits++-- | 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' :: CharParsing m => m Integer+integer' = int <?> "integer"++sign :: CharParsing m => m (Integer -> Integer)+sign = negate <$ char '-'+   <|> id <$ char '+'+   <|> pure id++int :: CharParsing m => m Integer+int = {-lexeme-} sign <*> nat+nat, zeroNumber :: CharParsing m => m Integer+nat = zeroNumber <|> decimal+zeroNumber = char '0' *> (hexadecimal <|> octal <|> decimal <|> return 0) <?> ""++-- | This 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.+--+-- This parser does NOT swallow trailing whitespace.++double' :: CharParsing m => m Double+double' = floating <?> "double"++floating :: CharParsing m => m Double+floating = decimal >>= fractExponent++fractExponent :: CharParsing m => Integer -> m Double+fractExponent n = (\fract expo -> (fromInteger n + fract) * expo) <$> fraction <*> option 1.0 exponent'+              <|> (fromInteger n *) <$> exponent' where+  fraction = Prelude.foldr op 0.0 <$> (char '.' *> (some digit <?> "fraction"))+  op d f = (f + fromIntegral (digitToInt d))/10.0+  exponent' = do+       _ <- oneOf "eE"+       f <- sign+       e <- decimal <?> "exponent"+       return (power (f e))+    <?> "exponent"+  power e+    | e < 0     = 1.0/power(-e)+    | otherwise = fromInteger (10^e)+++-- | This parser parses either 'natural' or a 'double'.+-- 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.+--+-- This parser does NOT swallow trailing whitespace.++naturalOrDouble' :: CharParsing m => m (Either Integer Double)+naturalOrDouble' = natDouble <?> "number"++natDouble, zeroNumFloat, decimalFloat :: CharParsing m => m (Either Integer Double)+natDouble+    = char '0' *> zeroNumFloat+  <|> decimalFloat+zeroNumFloat+    = Left <$> (hexadecimal <|> octal)+  <|> decimalFloat+  <|> fractFloat 0+  <|> return (Left 0)+decimalFloat = do+  n <- decimal+  option (Left n) (fractFloat n)++fractFloat :: CharParsing m => Integer -> m (Either Integer Double)+fractFloat n = Right <$> fractExponent n++-- | Parses a positive whole number in the decimal system. Returns the+-- value of the number.++decimal :: CharParsing m => m Integer+decimal = number 10 digit++-- | Parses a positive whole number in the hexadecimal system. The number+-- should be prefixed with \"x\" or \"X\". Returns the value of the+-- number.++hexadecimal :: CharParsing m => m Integer+hexadecimal = oneOf "xX" *> number 16 hexDigit++-- | Parses a positive whole number in the octal system. The number+-- should be prefixed with \"o\" or \"O\". Returns the value of the+-- number.++octal :: CharParsing m => m Integer+octal = oneOf "oO" *> number 8 octDigit+
+ Text/Parser/Combinators.hs view
@@ -0,0 +1,318 @@+{-# 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(..)+  -- * Alternative Parser 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+  ) 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 <?>++class (Alternative m, MonadPlus 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, 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, 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 :: Show a => m a -> m ()+  notFollowedBy p = try ((try p >>= unexpected . show) <|> pure ())++instance Parsing 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 => 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 => 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, 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, 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, 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, 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 => 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 view
@@ -0,0 +1,166 @@+-----------------------------------------------------------------------------+-- |+-- 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+                      => 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++              termP      = do{ pre  <- prefixP+                             ; x    <- term+                             ; post <- postfixP+                             ; return (post (pre 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 view
@@ -0,0 +1,140 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,309 @@+{-# 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+  ( TokenParsing(..)+  -- * Token Parsers+  , whiteSpace+  , token+  , charLiteral+  , stringLiteral+  , natural+  , integer+  , double+  , naturalOrDouble+  , symbol+  , symbolic+  , parens+  , braces+  , angles+  , brackets+  , comma+  , colon+  , dot+  , semiSep+  , semiSep1+  , commaSep+  , commaSep1+  -- * Identifiers+  , IdentifierStyle(..)+  , liftIdentifierStyle+  , ident+  , reserve+  ) where++import Control.Applicative+import Control.Monad (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.HashSet as HashSet+import Data.Monoid+import Text.Parser.Combinators+import Text.Parser.Char++-- | 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 <|> return ()+{-# 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++-- | 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 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 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'++-- | 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 int <?> "integer"+  where+  sign = negate <$ char '-'+    <|> id <$ char '+'+    <|> pure id+  int = token sign <*> natural'++-- | 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 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 naturalOrDouble'++-- | Token parser @symbol s@ parses 'string' @s@ and skips+-- trailing white space.++symbol :: TokenParsing m => String -> m String+symbol name = token (string name)++-- | Token parser @symbolic s@ parses 'char' @s@ and skips+-- trailing white space.++symbolic :: TokenParsing m => Char -> m Char+symbolic name = token (char name)++-- | 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 ')')++-- | 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 '}')++-- | 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 '>')++-- | 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 ']')++-- | Token parser @comma@ parses the character \',\' and skips any+-- trailing white space. Returns the string \",\".++comma :: TokenParsing m => m Char+comma = symbolic ','++-- | Token parser @colon@ parses the character \':\' and skips any+-- trailing white space. Returns the string \":\".++colon :: TokenParsing m => m Char+colon = symbolic ':'++-- | Token parser @dot@ parses the character \'.\' and skips any+-- trailing white space. Returns the string \".\".++dot :: TokenParsing m => m Char+dot = symbolic '.'++-- | 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++-- | 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++-- | 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++-- | 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++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 ())++instance TokenParsing m => TokenParsing (Lazy.StateT s m) where+  nesting (Lazy.StateT m) = Lazy.StateT $ nesting . m+  someSpace = lift someSpace+  semi      = lift semi+++instance TokenParsing m => TokenParsing (Strict.StateT s m) where+  nesting (Strict.StateT m) = Strict.StateT $ nesting . m+  someSpace = lift someSpace+  semi      = lift semi++instance TokenParsing m => TokenParsing (ReaderT e m) where+  nesting (ReaderT m) = ReaderT $ nesting . m+  someSpace = lift someSpace+  semi      = lift semi++instance (TokenParsing m, Monoid w) => TokenParsing (Strict.WriterT w m) where+  nesting (Strict.WriterT m) = Strict.WriterT $ nesting m+  someSpace = lift someSpace+  semi      = lift semi++instance (TokenParsing m, Monoid w) => TokenParsing (Lazy.WriterT w m) where+  nesting (Lazy.WriterT m) = Lazy.WriterT $ nesting m+  someSpace = lift someSpace+  semi      = lift semi++instance (TokenParsing 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++instance (TokenParsing 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++instance TokenParsing m => TokenParsing (IdentityT m) where+  nesting = IdentityT . nesting . runIdentityT+  someSpace = lift someSpace+  semi      = lift semi+++data IdentifierStyle m = IdentifierStyle+  { styleName              :: String+  , styleStart             :: m Char+  , styleLetter            :: m Char+  , styleReserved          :: HashSet String+  }++-- | 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)+    }++-- | parse a reserved operator or identifier using a given style+reserve :: TokenParsing m => IdentifierStyle m -> String -> m ()+reserve s name = token $ try $ do+   _ <- string name+   notFollowedBy (styleLetter s) <?> "end of " ++ show name++-- | parse an non-reserved identifier or symbol+ident :: TokenParsing m => IdentifierStyle m -> m String+ident s = token $ try $ do+  name <- (:) <$> styleStart s <*> many (styleLetter s) <?> styleName s+  when (member name (styleReserved s)) $ unexpected $ "reserved " ++ styleName s ++ " " ++ show name+  return name
+ Text/Parser/Token/Style.hs view
@@ -0,0 +1,115 @@+-----------------------------------------------------------------------------+-- |+-- 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 Data.List (nub)++data CommentStyle = CommentStyle+  { commentStart   :: String+  , commentEnd     :: String+  , commentLine    :: String+  , commentNesting :: Bool+  }++emptyCommentStyle, javaCommentStyle, haskellCommentStyle :: CommentStyle+emptyCommentStyle   = CommentStyle "" "" "" True+javaCommentStyle    = CommentStyle "/*" "*/" "//" True+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++emptyOps, haskell98Ops, haskellOps :: TokenParsing m => IdentifierStyle m+emptyOps = IdentifierStyle+  { styleName     = "operator"+  , styleStart    = styleLetter emptyOps+  , styleLetter   = oneOf ":!#$%&*+./<=>?@\\^|-~"+  , styleReserved = mempty+  }+haskell98Ops = emptyOps+  { styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"]+  }+haskellOps = haskell98Ops++emptyIdents, haskell98Idents, haskellIdents :: TokenParsing m => IdentifierStyle m+emptyIdents = IdentifierStyle+  { styleName     = "identifier"+  , styleStart    = letter <|> char '_'+  , styleLetter   = alphaNum <|> oneOf "_'"+  , styleReserved = set []+  }++haskell98Idents = emptyIdents+  { styleReserved = set haskell98ReservedIdents }+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
@@ -0,0 +1,46 @@+name:          parsers+category:      Text, Parsing+version:       0.1+license:       BSD3+cabal-version: >= 1.6+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      http://github.com/ekmett/parsers/+bug-reports:   http://github.com/ekmett/parsers/issues+copyright:     Copyright (C) 2010-2012 Edward A. Kmett+synopsis:      Simple parsing combinators+description:   Simple parsing combinators+build-type:    Simple++extra-source-files: .travis.yml++source-repository head+  type: git+  location: git://github.com/ekmett/parsers.git++library+  exposed-modules:+    Text.Parser.Char+    Text.Parser.Combinators+    Text.Parser.Permutation+    Text.Parser.Expression+    Text.Parser.Token+    Text.Parser.Token.Style++  ghc-options: -Wall++  build-depends:+    base                 >= 4       && < 5,+    charset              >= 0.3     && < 0.4,+    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