packages feed

parsec 2.1.0.1 → 3.0.0

raw patch · 25 files changed

+3094/−1747 lines, 25 filesdep +bytestringdep +mtldep ~basenew-uploader

Dependencies added: bytestring, mtl

Dependency ranges changed: base

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright 1999-2000, Daan Leijen. All rights reserved.+Copyright 1999-2000, Daan Leijen; 2007, Paolo Martini. All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+ Text/Parsec.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-----------------------------------------------------------------------------++module Text.Parsec+    ( module Text.Parsec.Prim+    , module Text.Parsec.Char+    , module Text.Parsec.Combinator+    , module Text.Parsec.String+    , module Text.Parsec.ByteString+    , module Text.Parsec.ByteString.Lazy+    , ParseError+    , errorPos+    , SourcePos+    , SourceName, Line, Column+    , sourceName, sourceLine, sourceColumn+    , incSourceLine, incSourceColumn+    , setSourceLine, setSourceColumn, setSourceName+    ) where++import Text.Parsec.Pos+import Text.Parsec.Error+import Text.Parsec.Prim+import Text.Parsec.Char+import Text.Parsec.Combinator+import Text.Parsec.String           hiding ( Parser, GenParser, parseFromFile )+import Text.Parsec.ByteString       hiding ( Parser, GenParser, parseFromFile )+import Text.Parsec.ByteString.Lazy  hiding ( Parser, GenParser, parseFromFile )
+ Text/Parsec/ByteString.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.ByteString+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Make strict ByteStrings an instance of 'Stream' with 'Char' token type.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.ByteString+    ( Parser, GenParser, parseFromFile+    ) where++import Text.Parsec.Error+import Text.Parsec.Prim++import qualified Data.ByteString.Char8 as C++instance (Monad m) => Stream C.ByteString m Char where+    uncons = return . C.uncons++type Parser = Parsec C.ByteString ()+type GenParser t st = Parsec C.ByteString st++-- | @parseFromFile p filePath@ runs a strict bytestring parser @p@ on the+-- input read from @filePath@ using 'ByteString.Char8.readFile'. Returns either a 'ParseError'+-- ('Left') or a value of type @a@ ('Right').+--+-- >  main    = do{ result <- parseFromFile numbers "digits.txt"+-- >              ; case result of+-- >                  Left err  -> print err+-- >                  Right xs  -> print (sum xs)+-- >              }++parseFromFile :: Parser a -> String -> IO (Either ParseError a)+parseFromFile p fname+    = do input <- C.readFile fname+         return (runP p () fname input)
+ Text/Parsec/ByteString/Lazy.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.ByteString.Lazy+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Make lazy ByteStrings an instance of 'Stream' with 'Char' token type.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.ByteString.Lazy+    ( Parser, GenParser, parseFromFile+    ) where++import Text.Parsec.Error+import Text.Parsec.Prim++import qualified Data.ByteString.Lazy.Char8 as C++instance (Monad m) => Stream C.ByteString m Char where+    uncons = return . C.uncons++type Parser = Parsec C.ByteString ()+type GenParser t st = Parsec C.ByteString st++-- | @parseFromFile p filePath@ runs a lazy bytestring parser @p@ on the+-- input read from @filePath@ using 'ByteString.Lazy.Char8.readFile'. Returns either a 'ParseError'+-- ('Left') or a value of type @a@ ('Right').+--+-- >  main    = do{ result <- parseFromFile numbers "digits.txt"+-- >              ; case result of+-- >                  Left err  -> print err+-- >                  Right xs  -> print (sum xs)+-- >              }+parseFromFile :: Parser a -> String -> IO (Either ParseError a)+parseFromFile p fname+    = do input <- C.readFile fname+         return (runP p () fname input)
+ Text/Parsec/Char.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Char+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Commonly used character parsers.+-- +-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}++module Text.Parsec.Char where++import Data.Char+import Text.Parsec.Pos+import Text.Parsec.Prim++-- | @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 :: (Stream s m Char) => [Char] -> ParsecT s u m Char+oneOf cs            = satisfy (\c -> elem c cs)++-- | 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 :: (Stream s m Char) => [Char] -> ParsecT s u m Char+noneOf cs           = satisfy (\c -> not (elem c cs))++-- | Skips /zero/ or more white space characters. See also 'skipMany'.++spaces :: (Stream s m Char) => ParsecT s u m ()+spaces              = skipMany space        <?> "white space"++-- | Parses a white space character (any character which satisfies 'isSpace')+-- Returns the parsed character. ++space :: (Stream s m Char) => ParsecT s u m Char+space               = satisfy isSpace       <?> "space"++-- | Parses a newline character (\'\\n\'). Returns a newline character. ++newline :: (Stream s m Char) => ParsecT s u m Char+newline             = char '\n'             <?> "new-line"++-- | Parses a tab character (\'\\t\'). Returns a tab character. ++tab :: (Stream s m Char) => ParsecT s u m Char+tab                 = char '\t'             <?> "tab"++-- | Parses an upper case letter (a character between \'A\' and \'Z\').+-- Returns the parsed character. ++upper :: (Stream s m Char) => ParsecT s u m Char+upper               = satisfy isUpper       <?> "uppercase letter"++-- | Parses a lower case character (a character between \'a\' and \'z\').+-- Returns the parsed character. ++lower :: (Stream s m Char) => ParsecT s u m Char+lower               = satisfy isLower       <?> "lowercase letter"++-- | Parses a letter or digit (a character between \'0\' and \'9\').+-- Returns the parsed character. ++alphaNum :: (Stream s m Char => ParsecT s u m Char)+alphaNum            = satisfy isAlphaNum    <?> "letter or digit"++-- | Parses a letter (an upper case or lower case character). Returns the+-- parsed character. ++letter :: (Stream s m Char) => ParsecT s u m Char+letter              = satisfy isAlpha       <?> "letter"++-- | Parses a digit. Returns the parsed character. ++digit :: (Stream s m Char) => ParsecT s u m Char+digit               = satisfy isDigit       <?> "digit"++-- | Parses a hexadecimal digit (a digit or a letter between \'a\' and+-- \'f\' or \'A\' and \'F\'). Returns the parsed character. ++hexDigit :: (Stream s m Char) => ParsecT s u m Char+hexDigit            = satisfy isHexDigit    <?> "hexadecimal digit"++-- | Parses an octal digit (a character between \'0\' and \'7\'). Returns+-- the parsed character. ++octDigit :: (Stream s m Char) => ParsecT s u m Char+octDigit            = satisfy isOctDigit    <?> "octal digit"++-- | @char c@ parses a single character @c@. Returns the parsed+-- character (i.e. @c@).+--+-- >  semiColon  = char ';'++char :: (Stream s m Char) => Char -> ParsecT s u m Char+char c              = satisfy (==c)  <?> show [c]++-- | This parser succeeds for any character. Returns the parsed character. ++anyChar :: (Stream s m Char) => ParsecT s u m Char+anyChar             = satisfy (const True)++-- | The parser @satisfy f@ succeeds for any character for which the+-- supplied function @f@ returns 'True'. Returns the character that is+-- actually parsed.++-- >  digit     = satisfy isDigit+-- >  oneOf cs  = satisfy (\c -> c `elem` cs)++satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char+satisfy f           = tokenPrim (\c -> show [c])+                                (\pos c _cs -> updatePosChar pos c)+                                (\c -> if f c then Just c else Nothing)++-- | @string s@ parses a sequence of characters given by @s@. Returns+-- the parsed string (i.e. @s@).+--+-- >  divOrMod    =   string "div" +-- >              <|> string "mod"++string :: (Stream s m Char) => String -> ParsecT s u m String+string s            = tokens show updatePosString s
+ Text/Parsec/Combinator.hs view
@@ -0,0 +1,286 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Combinator+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Commonly used generic combinators+-- +-----------------------------------------------------------------------------++module Text.Parsec.Combinator+    ( choice+    , count+    , between+    , option, optionMaybe, optional+    , skipMany1+    , many1+    , sepBy, sepBy1+    , endBy, endBy1+    , sepEndBy, sepEndBy1+    , chainl, chainl1+    , chainr, chainr1+    , eof, notFollowedBy+    -- tricky combinators+    , manyTill, lookAhead, anyToken+    ) where++import Control.Monad+import Text.Parsec.Prim++-- | @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 :: (Stream s m t) => [ParsecT s u m a] -> ParsecT s u m a+choice ps           = foldr (<|>) mzero ps++-- | @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 (do{ d <- digit+-- >                          ; return (digitToInt d) +-- >                          })++option :: (Stream s m t) => a -> ParsecT s u m a -> ParsecT s u m a+option x p          = p <|> return x++-- | @option p@ tries to apply parser @p@.  If @p@ fails without+-- consuming input, it return 'Nothing', otherwise it returns+-- 'Just' the value returned by @p@.++optionMaybe :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (Maybe a)+optionMaybe p       = option Nothing (liftM Just p)++-- | @optional 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@.++optional :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()+optional p          = do{ p; return ()} <|> return ()++-- | @between open close p@ parses @open@, followed by @p@ and @close@.+-- Returns the value returned by @p@.+--+-- >  braces  = between (symbol "{") (symbol "}")++between :: (Stream s m t) => ParsecT s u m open -> ParsecT s u m close+            -> ParsecT s u m a -> ParsecT s u m a+between open close p+                    = do{ open; x <- p; close; return x }++-- | @skipMany1 p@ applies the parser @p@ /one/ or more times, skipping+-- its result. ++skipMany1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()+skipMany1 p         = do{ p; skipMany p }+{-+skipMany p          = scan+                    where+                      scan  = do{ p; scan } <|> return ()+-}++-- | @many p@ applies the parser @p@ /one/ or more times. Returns a+-- list of the returned values of @p@.+--+-- >  word  = many1 letter++many1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a]+many1 p             = do{ x <- p; xs <- many p; return (x:xs) }+{-+many p              = scan id+                    where+                      scan f    = do{ x <- p+                                    ; scan (\tail -> f (x:tail))+                                    }+                                <|> return (f [])+-}+++-- | @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 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+sepBy p sep         = sepBy1 p sep <|> return []++-- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of values returned by @p@. ++sepBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+sepBy1 p sep        = do{ x <- p+                        ; xs <- many (sep >> p)+                        ; return (x:xs)+                        }+++-- | @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 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+sepEndBy1 p sep     = do{ x <- p+                        ; do{ sep+                            ; xs <- sepEndBy p sep+                            ; return (x:xs)+                            }+                          <|> return [x]+                        }++-- | @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 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+sepEndBy p sep      = sepEndBy1 p sep <|> return []+++-- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, seperated+-- and ended by @sep@. Returns a list of values returned by @p@. ++endBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+endBy1 p sep        = many1 (do{ x <- p; sep; return x })++-- | @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 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]+endBy p sep         = many (do{ x <- p; sep; return x })++-- | @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 :: (Stream s m t) => Int -> ParsecT s u m a -> ParsecT s u m [a]+count n p           | n <= 0    = return []+                    | otherwise = sequence (replicate n p)++-- | @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 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a+chainr p op x       = chainr1 p op <|> return x++-- | @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 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a+chainl p op x       = chainl1 p op <|> return x++-- | @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` mulop+-- >  term    = factor `chainl1` addop+-- >  factor  = parens expr <|> integer+-- >+-- >  mulop   =   do{ symbol "*"; return (*)   }+-- >          <|> do{ symbol "/"; return (div) }+-- >+-- >  addop   =   do{ symbol "+"; return (+) }+-- >          <|> do{ symbol "-"; return (-) }++chainl1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a+chainl1 p op        = do{ x <- p; rest x }+                    where+                      rest x    = do{ f <- op+                                    ; y <- p+                                    ; rest (f x y)+                                    }+                                <|> return x++-- | @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 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a+chainr1 p op        = scan+                    where+                      scan      = do{ x <- p; rest x }++                      rest x    = do{ f <- op+                                    ; y <- scan+                                    ; return (f x y)+                                    }+                                <|> return x++-----------------------------------------------------------+-- Tricky combinators+-----------------------------------------------------------+-- | The parser @anyToken@ accepts any kind of token. It is for example+-- used to implement 'eof'. Returns the accepted token. ++anyToken :: (Stream s m t, Show t) => ParsecT s u m t+anyToken            = tokenPrim show (\pos _tok _toks -> pos) Just++-- | This parser only succeeds at the end of the input. This is not a+-- primitive parser but it is defined using 'notFollowedBy'.+--+-- >  eof  = notFollowedBy anyToken <?> "end of input"++eof :: (Stream s m t, Show t) => ParsecT s u m ()+eof                 = notFollowedBy anyToken <?> "end of input"++-- | @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 (do{ string "let"+-- >                       ; notFollowedBy alphaNum+-- >                       })++notFollowedBy :: (Stream s m t, Show t) => ParsecT s u m t -> ParsecT s u m ()+notFollowedBy p     = try (do{ c <- p; unexpected (show [c]) }+                           <|> return ()+                          )++-- | @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 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]+manyTill p end      = scan+                    where+                      scan  = do{ end; return [] }+                            <|>+                              do{ x <- p; xs <- scan; return (x:xs) }++-- | @lookAhead p@ parses @p@ without consuming any input.++lookAhead :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m a+lookAhead p         = do{ state <- getParserState+                        ; x <- p+                        ; setParserState state+                        ; return x+                        }
+ Text/Parsec/Error.hs view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Error+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Parse errors+-- +-----------------------------------------------------------------------------++module Text.Parsec.Error+    ( Message ( SysUnExpect, UnExpect, Expect, Message )+    , messageString+    , ParseError, errorPos, errorMessages, errorIsUnknown+    , showErrorMessages+    , newErrorMessage, newErrorUnknown+    , addErrorMessage, setErrorPos, setErrorMessage+    , mergeError+    ) where++import Data.List ( nub, sort )++import Text.Parsec.Pos++-- | This abstract data type represents parse error messages. There are+-- four kinds of messages:+--+-- >  data Message = SysUnExpect String+-- >               | UnExpect String+-- >               | Expect String+-- >               | Message String+-- +-- The fine distinction between different kinds of parse errors allows+-- the system to generate quite good error messages for the user. It+-- also allows error messages that are formatted in different+-- languages. Each kind of message is generated by different combinators:+--+--     * A 'SysUnExpect' message is automatically generated by the+--       'Text.Parsec.Combinator.satisfy' combinator. The argument is the+--       unexpected input.+--+--     * A 'UnExpect' message is generated by the 'Text.Parsec.Prim.unexpected'+--       combinator. The argument describes the+--       unexpected item.+--+--     * A 'Expect' message is generated by the 'Text.Parsec.Prim.<?>'+--       combinator. The argument describes the expected item.+--+--     * A 'Message' message is generated by the 'fail'+--       combinator. The argument is some general parser message. ++data Message = SysUnExpect !String -- @ library generated unexpect+             | UnExpect    !String -- @ unexpected something+             | Expect      !String -- @ expecting something+             | Message     !String -- @ raw message++instance Enum Message where+    fromEnum (SysUnExpect _) = 0+    fromEnum (UnExpect    _) = 1+    fromEnum (Expect      _) = 2+    fromEnum (Message     _) = 3+    toEnum _ = error "toEnum is undefined for Message"++-- < Return 'True' only when 'compare' would return 'EQ'.++instance Eq Message where++    m1 == m2 = fromEnum m1 == fromEnum m2++-- < Compares two error messages without looking at their content. Only+-- the constructors are compared where:+-- +-- > 'SysUnExpect' < 'UnExpect' < 'Expect' < 'Message'++instance Ord Message where+    compare msg1 msg2 = compare (fromEnum msg1) (fromEnum msg2)++-- | Extract the message string from an error message ++messageString :: Message -> String+messageString (SysUnExpect s) = s+messageString (UnExpect    s) = s+messageString (Expect      s) = s+messageString (Message     s) = s++-- | The abstract data type @ParseError@ represents parse errors. It+-- provides the source position ('SourcePos') of the error+-- and a list of error messages ('Message'). A @ParseError@+-- can be returned by the function 'Text.Parsec.Prim.parse'. @ParseError@ is an+-- instance of the 'Show' class. ++data ParseError = ParseError !SourcePos [Message]++-- | Extracts the source position from the parse error++errorPos :: ParseError -> SourcePos+errorPos (ParseError pos _msgs)+    = pos++-- | Extracts the list of error messages from the parse error++errorMessages :: ParseError -> [Message]+errorMessages (ParseError _pos msgs)+    = sort msgs++errorIsUnknown :: ParseError -> Bool+errorIsUnknown (ParseError _pos msgs)+    = null msgs++-- < Create parse errors++newErrorUnknown :: SourcePos -> ParseError+newErrorUnknown pos+    = ParseError pos []++newErrorMessage :: Message -> SourcePos -> ParseError+newErrorMessage msg pos+    = ParseError pos [msg]++addErrorMessage :: Message -> ParseError -> ParseError+addErrorMessage msg (ParseError pos msgs)+    = ParseError pos (msg:msgs)++setErrorPos :: SourcePos -> ParseError -> ParseError+setErrorPos pos (ParseError _ msgs)+    = ParseError pos msgs++setErrorMessage :: Message -> ParseError -> ParseError+setErrorMessage msg (ParseError pos msgs)+    = ParseError pos (msg : filter (msg /=) msgs)++mergeError :: ParseError -> ParseError -> ParseError+mergeError (ParseError pos msgs1) (ParseError _ msgs2)+    = ParseError pos (msgs1 ++ msgs2)++instance Show ParseError where+    show err+        = show (errorPos err) ++ ":" +++          showErrorMessages "or" "unknown parse error"+                            "expecting" "unexpected" "end of input"+                           (errorMessages err)++-- Language independent show function++--  TODO+-- < The standard function for showing error messages. Formats a list of+--    error messages in English. This function is used in the |Show|+--    instance of |ParseError <#ParseError>|. The resulting string will be+--    formatted like:+--+--    |unexpected /{The first UnExpect or a SysUnExpect message}/;+--    expecting /{comma separated list of Expect messages}/;+--    /{comma separated list of Message messages}/++showErrorMessages ::+    String -> String -> String -> String -> String -> [Message] -> String+showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs+    | null msgs = msgUnknown+    | otherwise = concat $ map ("\n"++) $ clean $+                 [showSysUnExpect,showUnExpect,showExpect,showMessages]+    where+      (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs+      (unExpect,msgs2)    = span ((UnExpect    "") ==) msgs1+      (expect,messages)   = span ((Expect      "") ==) msgs2++      showExpect      = showMany msgExpecting expect+      showUnExpect    = showMany msgUnExpected unExpect+      showSysUnExpect | not (null unExpect) ||+                        null sysUnExpect = ""+                      | null firstMsg    = msgUnExpected ++ " " ++ msgEndOfInput+                      | otherwise        = msgUnExpected ++ " " ++ firstMsg+          where+              firstMsg  = messageString (head sysUnExpect)++      showMessages      = showMany "" messages++      -- helpers+      showMany pre msgs = case clean (map messageString msgs) of+                            [] -> ""+                            ms | null pre  -> commasOr ms+                               | otherwise -> pre ++ " " ++ commasOr ms++      commasOr []       = ""+      commasOr [m]      = m+      commasOr ms       = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms++      commaSep          = seperate ", " . clean++      seperate   _ []     = ""+      seperate   _ [m]    = m+      seperate sep (m:ms) = m ++ sep ++ seperate sep ms++      clean             = nub . filter (not . null)
+ Text/Parsec/Expr.hs view
@@ -0,0 +1,166 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Expr+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+-- +-- A helper module to parse \"expressions\".+-- Builds a parser given a table of operators and associativities.+-- +-----------------------------------------------------------------------------++module Text.Parsec.Expr+    ( Assoc(..), Operator(..), OperatorTable+    , buildExpressionParser+    ) where++import Text.Parsec.Prim+import Text.Parsec.Combinator++-----------------------------------------------------------+-- 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 s u m a   = Infix (ParsecT s u m (a -> a -> a)) Assoc+                        | Prefix (ParsecT s u m (a -> a))+                        | Postfix (ParsecT s u m (a -> a))++-- | An @OperatorTable s u m a@ is a list of @Operator s u 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 s u m a = [[Operator s u 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 (do{ reservedOp name; return fun }) assoc+-- >  prefix  name fun       = Prefix (do{ reservedOp name; return fun })+-- >  postfix name fun       = Postfix (do{ reservedOp name; return fun })++buildExpressionParser :: (Stream s m t)+                      => OperatorTable s u m a+                      -> ParsecT s u m a+                      -> ParsecT s u 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 $+                                  do{ 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  <- do{ z <- termP; rassocP1 z }+                             ; 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/Parsec/Language.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Language+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (uses non-portable module Text.Parsec.Token)+--+-- A helper module that defines some language definitions that can be used+-- to instantiate a token parser (see "Text.Parsec.Token").+-- +-----------------------------------------------------------------------------++module Text.Parsec.Language+    ( haskellDef, haskell+    , mondrianDef, mondrian+    , emptyDef+    , haskellStyle+    , javaStyle+    , LanguageDef+    , GenLanguageDef+    ) where++import Text.Parsec+import Text.Parsec.Token++-----------------------------------------------------------+-- Styles: haskellStyle, javaStyle+-----------------------------------------------------------++-- | This is a minimal token definition for Haskell style languages. It+-- defines the style of comments, valid identifiers and case+-- sensitivity. It does not define any reserved words or operators.++haskellStyle :: LanguageDef st+haskellStyle = emptyDef+                { commentStart   = "{-"+                , commentEnd     = "-}"+                , commentLine    = "--"+                , nestedComments = True+                , identStart     = letter+                , identLetter	 = alphaNum <|> oneOf "_'"+                , opStart	 = opLetter haskellStyle+                , opLetter	 = oneOf ":!#$%&*+./<=>?@\\^|-~"+                , reservedOpNames= []+                , reservedNames  = []+                , caseSensitive  = True+                }++-- | This is a minimal token definition for Java style languages. It+-- defines the style of comments, valid identifiers and case+-- sensitivity. It does not define any reserved words or operators.++javaStyle  :: LanguageDef st+javaStyle   = emptyDef+		{ commentStart	 = "/*"+		, commentEnd	 = "*/"+		, commentLine	 = "//"+		, nestedComments = True+		, identStart	 = letter+		, identLetter	 = alphaNum <|> oneOf "_'"+		, reservedNames  = []+		, reservedOpNames= []+                , caseSensitive  = False+		}++-----------------------------------------------------------+-- minimal language definition+--------------------------------------------------------++-- TODO: This seems wrong+-- < This is the most minimal token definition. It is recommended to use+-- this definition as the basis for other definitions. @emptyDef@ has+-- no reserved names or operators, is case sensitive and doesn't accept+-- comments, identifiers or operators.++emptyDef   :: LanguageDef st+emptyDef    = LanguageDef+               { commentStart   = ""+               , commentEnd     = ""+               , commentLine    = ""+               , nestedComments = True+               , identStart     = letter <|> char '_'+               , identLetter    = alphaNum <|> oneOf "_'"+               , opStart        = opLetter emptyDef+               , opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~"+               , reservedOpNames= []+               , reservedNames  = []+               , caseSensitive  = True+               }++++-----------------------------------------------------------+-- Haskell+-----------------------------------------------------------++-- | A lexer for the haskell language.++haskell :: TokenParser st+haskell      = makeTokenParser haskellDef++-- | The language definition for the Haskell language.++haskellDef  :: LanguageDef st+haskellDef   = haskell98Def+	        { identLetter	 = identLetter haskell98Def <|> char '#'+	        , reservedNames	 = reservedNames haskell98Def +++    				   ["foreign","import","export","primitive"+    				   ,"_ccall_","_casm_"+    				   ,"forall"+    				   ]+                }++-- | The language definition for the language Haskell98.++haskell98Def :: LanguageDef st+haskell98Def = haskellStyle+                { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"]+                , reservedNames  = ["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"+                                   ]+                }+++-----------------------------------------------------------+-- Mondrian+-----------------------------------------------------------++-- | A lexer for the mondrian language.++mondrian :: TokenParser st+mondrian    = makeTokenParser mondrianDef++-- | The language definition for the language Mondrian.++mondrianDef :: LanguageDef st+mondrianDef = javaStyle+		{ reservedNames = [ "case", "class", "default", "extends"+				  , "import", "in", "let", "new", "of", "package"+				  ]+                , caseSensitive  = True+		}
+ Text/Parsec/Perm.hs view
@@ -0,0 +1,181 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Perm+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (uses existentially quantified data constructors)+-- +-- This module implements permutation parsers. The algorithm used+-- is fairly complex since we push the type system to its limits :-)+-- 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.Parsec.Perm+    ( PermParser+    , StreamPermParser -- abstract++    , permute+    , (<||>), (<$$>)+    , (<|?>), (<$?>)+    ) where++import Text.Parsec++import Control.Monad.Identity++infixl 1 <||>, <|?>+infixl 2 <$$>, <$?>+++{---------------------------------------------------------------+  test -- parse a permutation of+  * an optional string of 'a's+  * a required 'b'+  * an optional 'c'+---------------------------------------------------------------}+{-+test input+  = parse (do{ x <- ptest; eof; return x }) "" input++ptest :: Parser (String,Char,Char)+ptest+  = permute $+    (,,) <$?> ("",many1 (char 'a'))+         <||> char 'b'+         <|?> ('_',char 'c')+-}++{---------------------------------------------------------------+  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@. ++(<||>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b+(<||>) perm p     = add perm p++-- | 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.++(<$$>) :: (Stream s Identity tok) => (a -> b) -> Parsec s st a -> StreamPermParser s st b+(<$$>) f p        = newperm 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@. ++(<|?>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st 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. ++(<$?>) :: (Stream s Identity tok) => (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b+(<$?>) f (x,p)    = newperm f <|?> (x,p)++{---------------------------------------------------------------+  The permutation tree+---------------------------------------------------------------}++-- | Provided for backwards compatibility.  The tok type is ignored.++type PermParser tok st a = StreamPermParser String st a++-- | The type @StreamPermParser s st a@ denotes a permutation parser that,+-- when converted by the 'permute' function, parses +-- @s@ streams with user state @st@ 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 StreamPermParser s st a = Perm (Maybe a) [StreamBranch s st a]++-- type Branch st a = StreamBranch String st a++data StreamBranch s st a = forall b. Branch (StreamPermParser s st (b -> a)) (Parsec s st b)++-- | 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 <$?> ("",many1 (char 'a'))+-- >                         <||> char 'b' +-- >                         <|?> ('_',char 'c'))+-- >        where+-- >          tuple a b c  = (a,b,c)++-- transform a permutation tree into a normal parser+permute :: (Stream s Identity tok) => StreamPermParser s st a -> Parsec s st a+permute (Perm def xs)+  = choice (map branch xs ++ empty)+  where+    empty+      = case def of+          Nothing -> []+          Just x  -> [return x]++    branch (Branch perm p)+      = do{ x <- p+          ; f <- permute perm+          ; return (f x)+          }++-- build permutation trees+newperm :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st (a -> b)+newperm f+  = Perm (Just f) []++add :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b+add perm@(Perm _mf fs) p+  = Perm Nothing (first:map insert fs)+  where+    first   = Branch perm p+    insert (Branch perm' p')+            = Branch (add (mapPerms flip perm') p) p'++addopt :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> a -> Parsec s st a -> StreamPermParser s st b+addopt perm@(Perm mf fs) x p+  = Perm (fmap ($ x) mf) (first:map insert fs)+  where+    first   = Branch perm p+    insert (Branch perm' p')+            = Branch (addopt (mapPerms flip perm') x p) p'+++mapPerms :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st a -> StreamPermParser s st b+mapPerms f (Perm x xs)+  = Perm (fmap f x) (map mapBranch xs)+  where+    mapBranch (Branch perm p)+      = Branch (mapPerms (f.) perm) p
+ Text/Parsec/Pos.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Pos+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Textual source positions.+-- +-----------------------------------------------------------------------------++module Text.Parsec.Pos+    ( SourceName, Line, Column+    , SourcePos+    , sourceLine, sourceColumn, sourceName+    , incSourceLine, incSourceColumn+    , setSourceLine, setSourceColumn, setSourceName+    , newPos, initialPos+    , updatePosChar, updatePosString+    ) where++-- < Source positions: a file name, a line and a column+-- upper left is (1,1)++type SourceName = String+type Line       = Int+type Column     = Int++-- | The abstract data type @SourcePos@ represents source positions. It+-- contains the name of the source (i.e. file name), a line number and+-- a column number. @SourcePos@ is an instance of the 'Show', 'Eq' and+-- 'Ord' class. ++data SourcePos  = SourcePos SourceName !Line !Column+    deriving ( Eq, Ord )++-- | Create a new 'SourcePos' with the given source name,+-- line number and column number.++newPos :: SourceName -> Line -> Column -> SourcePos+newPos name line column+    = SourcePos name line column++-- | Create a new 'SourcePos' with the given source name,+-- and line number and column number set to 1, the upper left.++initialPos :: SourceName -> SourcePos+initialPos name+    = newPos name 1 1++-- | Extracts the name of the source from a source position. ++sourceName :: SourcePos -> SourceName+sourceName (SourcePos name _line _column) = name++-- | Extracts the line number from a source position. ++sourceLine :: SourcePos -> Line+sourceLine (SourcePos _name line _column) = line++-- | Extracts the column number from a source position. ++sourceColumn :: SourcePos -> Column+sourceColumn (SourcePos _name _line column) = column++-- | Increments the line number of a source position. ++incSourceLine :: SourcePos -> Line -> SourcePos+incSourceLine (SourcePos name line column) n = SourcePos name (line+n) column++-- | Increments the column number of a source position. ++incSourceColumn :: SourcePos -> Column -> SourcePos+incSourceColumn (SourcePos name line column) n = SourcePos name line (column+n)++-- | Set the name of the source.++setSourceName :: SourcePos -> SourceName -> SourcePos+setSourceName (SourcePos _name line column) n = SourcePos n line column++-- | Set the line number of a source position. ++setSourceLine :: SourcePos -> Line -> SourcePos+setSourceLine (SourcePos name _line column) n = SourcePos name n column++-- | Set the column number of a source position. ++setSourceColumn :: SourcePos -> Column -> SourcePos+setSourceColumn (SourcePos name line _column) n = SourcePos name line n++-- | The expression @updatePosString pos s@ updates the source position+-- @pos@ by calling 'updatePosChar' on every character in @s@, ie.+-- @foldl updatePosChar pos string@. ++updatePosString :: SourcePos -> String -> SourcePos+updatePosString pos string+    = foldl updatePosChar pos string++-- | Update a source position given a character. If the character is a+-- newline (\'\\n\') or carriage return (\'\\r\') the line number is+-- incremented by 1. If the character is a tab (\'\t\') the column+-- number is incremented to the nearest 8'th column, ie. @column + 8 -+-- ((column-1) \`mod\` 8)@. In all other cases, the column is+-- incremented by 1. ++updatePosChar   :: SourcePos -> Char -> SourcePos+updatePosChar (SourcePos name line column) c+    = case c of+        '\n' -> SourcePos name (line+1) 1+        '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8))+        _    -> SourcePos name line (column + 1)++instance Show SourcePos where+  show (SourcePos name line column)+    | null name = showLineColumn+    | otherwise = "\"" ++ name ++ "\" " ++ showLineColumn+    where+      showLineColumn    = "(line " ++ show line +++                          ", column " ++ show column +++                          ")"
+ Text/Parsec/Prim.hs view
@@ -0,0 +1,670 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Prim+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- The primitive parser combinators.+-- +-----------------------------------------------------------------------------   ++{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts,+             UndecidableInstances #-}++module Text.Parsec.Prim where++import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )+import Control.Monad()+import Control.Monad.Trans+import Control.Monad.Identity++import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Cont.Class+import Control.Monad.Error.Class++import Text.Parsec.Pos+import Text.Parsec.Error++unknownError :: State s u -> ParseError+unknownError state        = newErrorUnknown (statePos state)++sysUnExpectError :: String -> SourcePos -> Reply s u a+sysUnExpectError msg pos  = Error (newErrorMessage (SysUnExpect msg) pos)++-- | The parser @unexpected msg@ always fails with an unexpected error+-- message @msg@ without consuming any input.+--+-- The parsers 'fail', ('<?>') and @unexpected@ are the three parsers+-- used to generate error messages. Of these, only ('<?>') is commonly+-- used. For an example of the use of @unexpected@, see the definition+-- of 'Text.Parsec.Combinator.notFollowedBy'.++unexpected :: (Stream s m t) => String -> ParsecT s u m a+unexpected msg+    = ParsecT $ \s -> return $ Empty $ return $ +                        Error (newErrorMessage (UnExpect msg) (statePos s))++-- | ParserT monad transformer and Parser type++-- | @ParsecT s u m a@ is a parser with stream type @s@, user state type @u@,+-- underlying monad @m@ and return type @a@++data ParsecT s u m a+    = ParsecT { runParsecT :: State s u -> m (Consumed (m (Reply s u a))) }++type Parsec s u = ParsecT s u Identity++data Consumed a  = Consumed a+                 | Empty !a++data Reply s u a = Ok !a !(State s u) ParseError+                 | Error ParseError++data State s u = State {+      stateInput :: s,+      statePos   :: !SourcePos,+      stateUser  :: !u+    }++instance Functor Consumed where+    fmap f (Consumed x) = Consumed (f x)+    fmap f (Empty x)    = Empty (f x)++instance Functor (Reply s u) where+    fmap f (Ok x s e) = Ok (f x) s e+    fmap _ (Error e) = Error e -- XXX++instance (Monad m) => Functor (ParsecT s u m) where+    fmap f p = parsecMap f p++parsecMap :: (Monad m) => (a -> b) -> ParsecT s u m a -> ParsecT s u m b+parsecMap f p+    = ParsecT $ \s -> liftM (fmap (liftM (fmap f))) (runParsecT p s)++instance (Monad m) => Applicative.Applicative (ParsecT s u m) where+    pure = return+    (<*>) = ap -- TODO: Can this be optimized?++instance (Monad m) => Applicative.Alternative (ParsecT s u m) where+    empty = mzero+    (<|>) = mplus++instance (Monad m) => Monad (ParsecT s u m) where+    return x = parserReturn x+    p >>= f  = parserBind p f+    fail msg = parserFail msg++instance (MonadIO m) => MonadIO (ParsecT s u m) where+    liftIO = lift . liftIO++instance (MonadReader r m) => MonadReader r (ParsecT s u m) where+    ask = lift ask+    local f p = ParsecT $ \s -> local f (runParsecT p s)++-- I'm presuming the user might want a separate, non-backtracking+-- state aside from the Parsec user state.+instance (MonadState s m) => MonadState s (ParsecT s' u m) where+    get = lift get+    put = lift . put++instance (MonadCont m) => MonadCont (ParsecT s u m) where+    callCC f = ParsecT $ \s ->+          callCC $ \c ->+          runParsecT (f (\a -> ParsecT $ \s' -> c (pack s' a))) s++     where pack s a= Empty $ return (Ok a s (unknownError s))++instance (MonadError e m) => MonadError e (ParsecT s u m) where+    throwError = lift . throwError+    p `catchError` h = ParsecT $ \s ->+        runParsecT p s `catchError` \e ->+            runParsecT (h e) s++parserReturn :: (Monad m) => a -> ParsecT s u m a+parserReturn x+    = ParsecT $ \s -> return $ Empty $ return (Ok x s (unknownError s))++parserBind :: (Monad m)+           => ParsecT s u m a -> (a -> ParsecT s u m b) -> ParsecT s u m b++parserBind p f+    = ParsecT $ \s -> do -- TODO: This was \s@(State _ u _) ???+        res1 <- runParsecT p s+        case res1 of++          Empty mReply1+            -> do reply1 <- mReply1+                  case reply1 of+                    Ok x s' err1 -> do+                      res2 <- runParsecT (f x) s'+                      case res2 of+                        Empty mReply2+                          -> do reply2 <- mReply2+                                return $ Empty $+                                            return $ mergeErrorReply err1 reply2+                        other+                          -> do return $ other+                    Error err1 -> return $ Empty $ return $ Error err1++          Consumed mReply1+            -> do reply1 <- mReply1+                  return $ Consumed $ -- `early' returning+                    case reply1 of+                      Ok x s' err1 -> do+                        res2 <- runParsecT (f x) s'+                        case res2 of+                          Empty mReply2+                            -> do reply2 <- mReply2+                                  return $ mergeErrorReply err1 reply2+                          Consumed reply2 -> reply2+                      Error err1   -> return $ Error err1+++mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a+mergeErrorReply err1 reply -- XXX where to put it?+    = case reply of+        Ok x state err2 -> Ok x state (mergeError err1 err2)+        Error err2      -> Error (mergeError err1 err2)++parserFail :: (Monad m) => String -> ParsecT s u m a+parserFail msg+    = ParsecT $ \s -> return $ Empty $ return $+        Error (newErrorMessage (Message msg) (statePos s))++instance (Monad m) => MonadPlus (ParsecT s u m) where+    mzero = parserZero+    mplus p1 p2 = parserPlus p1 p2++-- | @parserZero@ always fails without consuming any input. @parserZero@ is defined+-- equal to the 'mzero' member of the 'MonadPlus' class and to the 'Control.Applicative.empty' member +-- of the 'Control.Applicative.Applicative' class.++parserZero :: (Monad m) => ParsecT s u m a+parserZero+    = ParsecT $ \s -> return $ Empty $ return $ Error (unknownError s)++parserPlus :: (Monad m)+           => ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a+parserPlus (ParsecT p1) (ParsecT p2)+    = ParsecT $ \s -> do+        c1 <- p1 s+        case c1 of+          Empty mReply1+            -> do r1 <- mReply1+                  case r1 of+                    Error err -> do+                      c2 <- p2 s+                      case c2 of+                        Empty mReply2+                          -> do reply2 <- mReply2+                                return $ Empty $ return (mergeErrorReply err reply2)+                        consumed+                          -> return $ consumed+                    other -> return $ Empty $ return $ other+          other -> return $ other++instance MonadTrans (ParsecT s u) where+    lift amb = ParsecT $ \s -> do+                 a <- amb+                 return $ Empty $ return $ Ok a s (unknownError s)++infix  0 <?>+infixr 1 <|>++-- | The parser @p <?> msg@ behaves as parser @p@, but whenever the+-- parser @p@ fails /without consuming any input/, it replaces expect+-- error messages with the expect error message @msg@.+--+-- This is normally used at the end of a set alternatives where we want+-- to return an error message in terms of a higher level construct+-- rather than returning all possible characters. For example, if the+-- @expr@ parser from the 'try' example would fail, the error+-- message is: '...: expecting expression'. Without the @(\<?>)@+-- combinator, the message would be like '...: expecting \"let\" or+-- letter', which is less friendly.++(<?>) :: (Monad m)+      => (ParsecT s u m a) -> String -> (ParsecT s u m a)+p <?> msg = label p msg++-- | This combinator implements choice. The parser @p \<|> q@ first+-- applies @p@. If it succeeds, the value of @p@ is returned. If @p@+-- fails /without consuming any input/, parser @q@ is tried. This+-- combinator is defined equal to the 'mplus' member of the 'MonadPlus'+-- class and the ('Control.Applicative.<|>') member of 'Control.Applicative.Alternative'.+--+-- The parser is called /predictive/ since @q@ is only tried when+-- parser @p@ didn't consume any input (i.e.. the look ahead is 1).+-- This non-backtracking behaviour allows for both an efficient+-- implementation of the parser combinators and the generation of good+-- error messages.++(<|>) :: (Monad m)+      => (ParsecT s u m a) -> (ParsecT s u m a) -> (ParsecT s u m a)+p1 <|> p2 = mplus p1 p2++label :: (Monad m) => ParsecT s u m a -> String -> ParsecT s u m a+label p msg+  = labels p [msg]++labels :: (Monad m) => ParsecT s u m a -> [String] -> ParsecT s u m a+labels p msgs+    = ParsecT $ \s -> do+        r <- runParsecT p s+        case r of+          Empty mReply -> do+            reply <- mReply+            return $ Empty $ case reply of+              Error err+                -> return $ Error (setExpectErrors err msgs)+              Ok x s' err+                | errorIsUnknown err -> return $ reply+                | otherwise -> return (Ok x s' (setExpectErrors err msgs))+          other        -> return $ other+    where+        setExpectErrors err []         = setErrorMessage (Expect "") err+        setExpectErrors err [msg]      = setErrorMessage (Expect msg) err+        setExpectErrors err (msg:msgs)+            = foldr (\msg' err' -> addErrorMessage (Expect msg') err')+                    (setErrorMessage (Expect msg) err) msgs++-- TODO: There should be a stronger statement that can be made about this++-- | An instance of @Stream@ has stream type @s@, underlying monad @m@ and token type @t@ determined by the stream+-- +-- Some rough guidelines for a \"correct\" instance of Stream:+--+--    * unfoldM uncons gives the [t] corresponding to the stream+--+--    * A @Stream@ instance is responsible for maintaining the \"position within the stream\" in the stream state @s@.  This is trivial unless you are using the monad in a non-trivial way.++class (Monad m) => Stream s m t | s -> t where+    uncons :: s -> m (Maybe (t,s))++tokens :: (Stream s m t, Eq t)+       => ([t] -> String)      -- Pretty print a list of tokens+       -> (SourcePos -> [t] -> SourcePos)+       -> [t]                  -- List of tokens to parse+       -> ParsecT s u m [t]+tokens _ _ []+    = ParsecT $ \s -> return $ Empty $ return $ Ok [] s (unknownError s)+tokens showTokens nextposs tts@(tok:toks)+    = ParsecT $ \(State input pos u) -> +    let+        errEof = return $ Error (setErrorMessage (Expect (showTokens tts))+                                 (newErrorMessage (SysUnExpect "") pos))+        errExpect x = return $ Error (setErrorMessage (Expect (showTokens tts))+                                 (newErrorMessage (SysUnExpect (showTokens [x])) pos))+        walk []     rs = return (ok rs)+        walk (t:ts) rs = do+          sr <- uncons rs+          case sr of+            Nothing                 -> errEof+            Just (x,xs) | t == x    -> walk ts xs+                        | otherwise -> errExpect x+        ok rs = let pos' = nextposs pos tts+                    s' = State rs pos' u+                in Ok tts s' (newErrorUnknown pos')+    in do+        sr <- uncons input+        return $ case sr of+            Nothing         -> Empty    $ errEof+            Just (x,xs)+                | tok == x    -> Consumed $ walk toks xs+                | otherwise -> Empty    $ errExpect x+        +-- | The parser @try p@ behaves like parser @p@, except that it+-- pretends that it hasn't consumed any input when an error occurs.+--+-- This combinator is used whenever arbitrary look ahead is needed.+-- Since it pretends that it hasn't consumed any input when @p@ fails,+-- the ('<|>') combinator will try its second alternative even when the+-- first parser failed while consuming input.+--+-- The @try@ combinator can for example be used to distinguish+-- identifiers and reserved words. Both reserved words and identifiers+-- are a sequence of letters. Whenever we expect a certain reserved+-- word where we can also expect an identifier we have to use the @try@+-- combinator. Suppose we write:+--+-- >  expr        = letExpr <|> identifier <?> "expression"+-- >+-- >  letExpr     = do{ string "let"; ... }+-- >  identifier  = many1 letter+--+-- If the user writes \"lexical\", the parser fails with: @unexpected+-- \'x\', expecting \'t\' in \"let\"@. Indeed, since the ('<|>') combinator+-- only tries alternatives when the first alternative hasn't consumed+-- input, the @identifier@ parser is never tried (because the prefix+-- \"le\" of the @string \"let\"@ parser is already consumed). The+-- right behaviour can be obtained by adding the @try@ combinator:+--+-- >  expr        = letExpr <|> identifier <?> "expression"+-- >+-- >  letExpr     = do{ try (string "let"); ... }+-- >  identifier  = many1 letter++try :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m a+try (ParsecT p)+    = ParsecT $ \s@(State _ pos _) -> do+        res <- p s+        case res of+          Consumed rep -> do r <- rep+                             case r of+                               Error err -> return $ Empty $ return $ Error+                                                         (setErrorPos pos err)+                               ok        -> return $ Consumed $ return $ ok+          empty        -> return $ empty++-- | The parser @token showTok posFromTok testTok@ accepts a token @t@+-- with result @x@ when the function @testTok t@ returns @'Just' x@. The+-- source position of the @t@ should be returned by @posFromTok t@ and+-- the token can be shown using @showTok t@.+--+-- This combinator is expressed in terms of 'tokenPrim'.+-- It is used to accept user defined token streams. For example,+-- suppose that we have a stream of basic tokens tupled with source+-- positions. We can than define a parser that accepts single tokens as:+--+-- >  mytoken x+-- >    = token showTok posFromTok testTok+-- >    where+-- >      showTok (pos,t)     = show t+-- >      posFromTok (pos,t)  = pos+-- >      testTok (pos,t)     = if x == t then Just t else Nothing++token :: (Stream s Identity t)+      => (t -> String)            -- ^ Token pretty-printing function.+      -> (t -> SourcePos)         -- ^ Computes the position of a token.+      -> (t -> Maybe a)           -- ^ Matching function for the token to parse.+      -> Parsec s u a+token showToken tokpos test = tokenPrim showToken nextpos test+    where+        nextpos _ tok ts = case runIdentity (uncons ts) of+                             Nothing -> tokpos tok+                             Just (tok',_) -> tokpos tok'++-- | The parser @token showTok nextPos testTok@ accepts a token @t@+-- with result @x@ when the function @testTok t@ returns @'Just' x@. The+-- token can be shown using @showTok t@. The position of the /next/+-- token should be returned when @nextPos@ is called with the current+-- source position @pos@, the current token @t@ and the rest of the+-- tokens @toks@, @nextPos pos t toks@.+--+-- This is the most primitive combinator for accepting tokens. For+-- example, the 'Text.Parsec.Char.char' parser could be implemented as:+--+-- >  char c+-- >    = tokenPrim showChar nextPos testChar+-- >    where+-- >      showChar x        = "'" ++ x ++ "'"+-- >      testChar x        = if x == c then Just x else Nothing+-- >      nextPos pos x xs  = updatePosChar pos x++tokenPrim :: (Stream s m t)+          => (t -> String)                      -- ^ Token pretty-printing function.+          -> (SourcePos -> t -> s -> SourcePos) -- ^ Next position calculating function.+          -> (t -> Maybe a)                     -- ^ Matching function for the token to parse.+          -> ParsecT s u m a+tokenPrim showToken nextpos test = tokenPrimEx showToken nextpos Nothing test++tokenPrimEx :: (Stream s m t)+            => (t -> String)      +            -> (SourcePos -> t -> s -> SourcePos)+            -> Maybe (SourcePos -> t -> s -> u -> u)+            -> (t -> Maybe a)     +            -> ParsecT s u m a+tokenPrimEx showToken nextpos mbNextState test+    = case mbNextState of+        Nothing+          -> ParsecT $ \(State input pos user) -> do+              r <- uncons input+              case r of+                Nothing -> return $ Empty $ return (sysUnExpectError "" pos)+                Just (c,cs)+                  -> case test c of+                       Just x  -> let newpos   = nextpos pos c cs+                                      newstate = State cs newpos user+                                  in seq newpos $ seq newstate $+                                     return $ Consumed $ return $+                                       (Ok x newstate (newErrorUnknown newpos))+                       Nothing -> return $ Empty $ return $+                                    (sysUnExpectError (showToken c) pos)+        Just nextState+          -> ParsecT $ \(State input pos user) -> do+              r <- uncons input+              case r of+                Nothing -> return $ Empty $ return (sysUnExpectError "" pos)+                Just (c,cs)+                  -> case test c of+                       Just x  -> let newpos   = nextpos pos c cs+                                      newuser  = nextState pos c cs user+                                      newstate = State cs newpos newuser+                                  in seq newpos $ seq newstate $+                                     return $ Consumed $ return $+                                       (Ok x newstate (newErrorUnknown newpos))+                       Nothing -> return $ Empty $ return $+                                    (sysUnExpectError (showToken c) pos)++-- | @many p@ applies the parser @p@ /zero/ or more times. Returns a+--    list of the returned values of @p@.+--+-- >  identifier  = do{ c  <- letter+-- >                  ; cs <- many (alphaNum <|> char '_')+-- >                  ; return (c:cs)+-- >                  }++many :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a]+many p+  = do xs <- manyAccum (:) p+       return (reverse xs)++-- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping+-- its result.+--+-- >  spaces  = skipMany space++skipMany :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()+skipMany p+  = do manyAccum (\_ _ -> []) p+       return ()++manyAccum :: (Stream s m t)+          => (a -> [a] -> [a])+          -> ParsecT s u m a+          -> ParsecT s u m [a]+manyAccum accum p+    = ParsecT $ \s ->+        let walk xs state mr+              = do r <- mr+                   case r of+                     Empty mReply+                         -> do reply <- mReply+                               case reply of+                                 Error err -> return $ Ok xs state err+                                 _         -> error "Text.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."+                     Consumed mReply+                         -> do reply <- mReply+                               case reply of+                                 Error err+                                     -> return $ Error err+                                 Ok x s' _err+                                     -> let ys = accum x xs+                                        in seq ys (walk ys s' (runParsecT p s'))+        in do r <- runParsecT p s+              case r of+                Empty mReply+                    -> do reply <- mReply+                          case reply of+                            Ok _ _ _+                                -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."+                            Error err+                                -> return $ Empty $ return (Ok [] s err)+                consumed+                    -> return $ Consumed $ walk [] s (return consumed)+++-- < Running a parser: monadic (runPT) and pure (runP)++runPT :: (Stream s m t)+      => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)+runPT p u name s+    = do res <- runParsecT p (State s (initialPos name) u)+         r <- parserReply res+         case r of+           Ok x _ _  -> return (Right x)+           Error err -> return (Left err)+    where+        parserReply res+            = case res of+                Consumed r -> r+                Empty    r -> r++runP :: (Stream s Identity t)+     => Parsec s u a -> u -> SourceName -> s -> Either ParseError a+runP p u name s = runIdentity $ runPT p u name s++-- | The most general way to run a parser. @runParserT p state filePath+-- input@ runs parser @p@ on the input list of tokens @input@,+-- obtained from source @filePath@ with the initial user state @st@.+-- The @filePath@ is only used in error messages and may be the empty+-- string. Returns a computation in the underlying monad @m@ that return either a 'ParseError' ('Left') or a+-- value of type @a@ ('Right').++runParserT :: (Stream s m t)+           => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)+runParserT = runPT++-- | The most general way to run a parser over the Identity monad. @runParser p state filePath+-- input@ runs parser @p@ on the input list of tokens @input@,+-- obtained from source @filePath@ with the initial user state @st@.+-- The @filePath@ is only used in error messages and may be the empty+-- string. Returns either a 'ParseError' ('Left') or a+-- value of type @a@ ('Right').+--+-- >  parseFromFile p fname+-- >    = do{ input <- readFile fname+-- >        ; return (runParser p () fname input)+-- >        }++runParser :: (Stream s Identity t)+          => Parsec s u a -> u -> SourceName -> s -> Either ParseError a+runParser = runP++-- | @parse p filePath input@ runs a parser @p@ over Identity without user+-- state. The @filePath@ is only used in error messages and may be the+-- empty string. Returns either a 'ParseError' ('Left')+-- or a value of type @a@ ('Right').+--+-- >  main    = case (parse numbers "" "11, 2, 43") of+-- >             Left err  -> print err+-- >             Right xs  -> print (sum xs)+-- >+-- >  numbers = commaSep integer++parse :: (Stream s Identity t)+      => Parsec s () a -> SourceName -> s -> Either ParseError a+parse p = runP p ()++-- | The expression @parseTest p input@ applies a parser @p@ against+-- input @input@ and prints the result to stdout. Used for testing+-- parsers.++parseTest :: (Stream s Identity t, Show a)+          => Parsec s () a -> s -> IO ()+parseTest p input+    = case parse p "" input of+        Left err -> do putStr "parse error at "+                       print err+        Right x  -> print x++-- < Parser state combinators++-- | Returns the current source position. See also 'SourcePos'.++getPosition :: (Monad m) => ParsecT s u m SourcePos+getPosition = do state <- getParserState+                 return (statePos state)++-- | Returns the current input ++getInput :: (Monad m) => ParsecT s u m s+getInput = do state <- getParserState+              return (stateInput state)++-- | @setPosition pos@ sets the current source position to @pos@. ++setPosition :: (Monad m) => SourcePos -> ParsecT s u m ()+setPosition pos+    = do updateParserState (\(State input _ user) -> State input pos user)+         return ()++-- | @setInput input@ continues parsing with @input@. The 'getInput' and+-- @setInput@ functions can for example be used to deal with #include+-- files. ++setInput :: (Monad m) => s -> ParsecT s u m ()+setInput input+    = do updateParserState (\(State _ pos user) -> State input pos user)+         return ()++-- | Returns the full parser state as a 'State' record.++getParserState :: (Monad m) => ParsecT s u m (State s u)+getParserState = updateParserState id++-- | @setParserState st@ set the full parser state to @st@. ++setParserState :: (Monad m) => State s u -> ParsecT s u m (State s u)+setParserState st = updateParserState (const st)++-- | @updateParserState f@ applies function @f@ to the parser state.++updateParserState :: (Monad m)+                  => (State s u -> State s u) -> ParsecT s u m (State s u)+updateParserState f+    = ParsecT $ \s -> let s' = f s+                      in return $ Empty $ return (Ok s' s' (unknownError s'))++-- < User state combinators++-- | Returns the current user state. ++getState :: (Monad m) => ParsecT s u m u+getState = stateUser `liftM` getParserState++-- | @putState st@ set the user state to @st@. ++putState :: (Monad m) => u -> ParsecT s u m ()+putState u = do updateParserState $ \s -> s { stateUser = u }+                return ()++-- | @updateState f@ applies function @f@ to the user state. Suppose+-- that we want to count identifiers in a source, we could use the user+-- state as:+--+-- >  expr  = do{ x <- identifier+-- >            ; updateState (+1)+-- >            ; return (Id x)+-- >            }++modifyState :: (Monad m) => (u -> u) -> ParsecT s u m ()+modifyState f = do updateParserState $ \s -> s { stateUser = f (stateUser s) }+                   return ()++-- XXX Compat++-- | An alias for putState for backwards compatibility.++setState :: (Monad m) => u -> ParsecT s u m ()+setState = putState++-- | An alias for modifyState for backwards compatibility.++updateState :: (Monad m) => (u -> u) -> ParsecT s u m ()+updateState = modifyState
+ Text/Parsec/String.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.String+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  portable+-- +-- Make Strings an instance of 'Stream' with 'Char' token type.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Text.Parsec.String+    ( Parser, GenParser, parseFromFile+    ) where++import Text.Parsec.Error+import Text.Parsec.Prim++instance (Monad m) => Stream [tok] m tok where+    uncons []     = return $ Nothing+    uncons (t:ts) = return $ Just (t,ts)++type Parser = Parsec String ()+type GenParser tok st = Parsec [tok] st++-- | @parseFromFile p filePath@ runs a string parser @p@ on the+-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError'+-- ('Left') or a value of type @a@ ('Right').+--+-- >  main    = do{ result <- parseFromFile numbers "digits.txt"+-- >              ; case result of+-- >                  Left err  -> print err+-- >                  Right xs  -> print (sum xs)+-- >              }+parseFromFile :: Parser a -> String -> IO (Either ParseError a)+parseFromFile p fname+    = do input <- readFile fname+         return (runP p () fname input)
+ Text/Parsec/Token.hs view
@@ -0,0 +1,722 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Parsec.Token+-- Copyright   :  (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file)+-- +-- Maintainer  :  derek.a.elkins@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable (uses local universal quantification: PolymorphicComponents)+-- +-- A helper module to parse lexical elements (tokens). See 'makeTokenParser'+-- for a description of how to use it.+-- +-----------------------------------------------------------------------------++{-# LANGUAGE PolymorphicComponents #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Text.Parsec.Token+    ( LanguageDef+    , GenLanguageDef (..)+    , TokenParser+    , GenTokenParser (..)+    , makeTokenParser+    ) where++import Data.Char ( isAlpha, toLower, toUpper, isSpace, digitToInt )+import Data.List ( nub, sort )+import Control.Monad.Identity+import Text.Parsec.Prim+import Text.Parsec.Char+import Text.Parsec.Combinator++-----------------------------------------------------------+-- Language Definition+-----------------------------------------------------------++type LanguageDef st = GenLanguageDef String st Identity++-- | The @GenLanguageDef@ type is a record that contains all parameterizable+-- features of the 'Text.Parsec.Token' module. The module 'Text.Parsec.Language'+-- contains some default definitions.++data GenLanguageDef s u m+    = LanguageDef { +    +    -- | Describes the start of a block comment. Use the empty string if the+    -- language doesn't support block comments. For example \"\/*\". ++    commentStart   :: String,++    -- | Describes the end of a block comment. Use the empty string if the+    -- language doesn't support block comments. For example \"*\/\". ++    commentEnd     :: String,++    -- | Describes the start of a line comment. Use the empty string if the+    -- language doesn't support line comments. For example \"\/\/\". ++    commentLine    :: String,++    -- | Set to 'True' if the language supports nested block comments. ++    nestedComments :: Bool,++    -- | This parser should accept any start characters of identifiers. For+    -- example @letter \<|> char \"_\"@. ++    identStart     :: ParsecT s u m Char,++    -- | This parser should accept any legal tail characters of identifiers.+    -- For example @alphaNum \<|> char \"_\"@. ++    identLetter    :: ParsecT s u m Char,++    -- | This parser should accept any start characters of operators. For+    -- example @oneOf \":!#$%&*+.\/\<=>?\@\\\\^|-~\"@ ++    opStart        :: ParsecT s u m Char,++    -- | This parser should accept any legal tail characters of operators.+    -- Note that this parser should even be defined if the language doesn't+    -- support user-defined operators, or otherwise the 'reservedOp'+    -- parser won't work correctly. ++    opLetter       :: ParsecT s u m Char,++    -- | The list of reserved identifiers. ++    reservedNames  :: [String],++    -- | The list of reserved operators. ++    reservedOpNames:: [String],++    -- | Set to 'True' if the language is case sensitive. ++    caseSensitive  :: Bool++    }++-----------------------------------------------------------+-- A first class module: TokenParser+-----------------------------------------------------------++type TokenParser st = GenTokenParser String st Identity++-- | The type of the record that holds lexical parsers that work on+-- @s@ streams with state @u@ over a monad @m@.++data GenTokenParser s u m+    = TokenParser {++        -- | This lexeme parser parses a legal identifier. Returns the identifier+        -- string. This parser will fail on identifiers that are reserved+        -- words. Legal identifier (start) characters and reserved words are+        -- defined in the 'LanguageDef' that is passed to+        -- 'makeTokenParser'. An @identifier@ is treated as+        -- a single token using 'try'.++        identifier       :: ParsecT s u m String,+        +        -- | The lexeme parser @reserved name@ parses @symbol +        -- name@, but it also checks that the @name@ is not a prefix of a+        -- valid identifier. A @reserved@ word is treated as a single token+        -- using 'try'. ++        reserved         :: String -> ParsecT s u m (),++        -- | This lexeme parser parses a legal operator. Returns the name of the+        -- operator. This parser will fail on any operators that are reserved+        -- operators. Legal operator (start) characters and reserved operators+        -- are defined in the 'LanguageDef' that is passed to+        -- 'makeTokenParser'. An @operator@ is treated as a+        -- single token using 'try'. ++        operator         :: ParsecT s u m String,++        -- |The lexeme parser @reservedOp name@ parses @symbol+        -- name@, but it also checks that the @name@ is not a prefix of a+        -- valid operator. A @reservedOp@ is treated as a single token using+        -- 'try'. ++        reservedOp       :: String -> ParsecT s u m (),+++        -- | This lexeme 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      :: ParsecT s u m Char,++        -- | This lexeme 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    :: ParsecT s u m String,++        -- | This lexeme 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          :: ParsecT s u m Integer,++        -- | This lexeme 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          :: ParsecT s u m Integer,++        -- | This lexeme 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. ++        float            :: ParsecT s u m Double,++        -- | This lexeme 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. ++        naturalOrFloat   :: ParsecT s u m (Either Integer Double),++        -- | Parses a positive whole number in the decimal system. Returns the+        -- value of the number. ++        decimal          :: ParsecT s u m Integer,++        -- | Parses a positive whole number in the hexadecimal system. The number+        -- should be prefixed with \"0x\" or \"0X\". Returns the value of the+        -- number. ++        hexadecimal      :: ParsecT s u m Integer,++        -- | Parses a positive whole number in the octal system. The number+        -- should be prefixed with \"0o\" or \"0O\". Returns the value of the+        -- number. ++        octal            :: ParsecT s u m Integer,++        -- | Lexeme parser @symbol s@ parses 'string' @s@ and skips+        -- trailing white space. ++        symbol           :: String -> ParsecT s u m String,++        -- | @lexeme p@ first applies parser @p@ and than the 'whiteSpace'+        -- parser, returning the value of @p@. Every lexical+        -- token (lexeme) is defined using @lexeme@, this way every parse+        -- starts at a point without white space. Parsers that use @lexeme@ are+        -- called /lexeme/ 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  = do{ whiteSpace+        -- >                     ; ds <- many (lexeme digit)+        -- >                     ; eof+        -- >                     ; return (sum ds)+        -- >                     }++        lexeme           :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Parses any white space. White space consists of /zero/ or more+        -- occurrences of a 'space', a line comment or a block (multi+        -- line) comment. Block comments may be nested. How comments are+        -- started and ended is defined in the 'LanguageDef'+        -- that is passed to 'makeTokenParser'. ++        whiteSpace       :: ParsecT s u m (),++        -- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis,+        -- returning the value of @p@.++        parens           :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Lexeme parser @braces p@ parses @p@ enclosed in braces (\'{\' and+        -- \'}\'), returning the value of @p@. ++        braces           :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Lexeme parser @angles p@ parses @p@ enclosed in angle brackets (\'\<\'+        -- and \'>\'), returning the value of @p@. ++        angles           :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Lexeme parser @brackets p@ parses @p@ enclosed in brackets (\'[\'+        -- and \']\'), returning the value of @p@. ++        brackets         :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | DEPRECATED: Use 'brackets'.++        squares          :: forall a. ParsecT s u m a -> ParsecT s u m a,++        -- | Lexeme parser |semi| parses the character \';\' and skips any+        -- trailing white space. Returns the string \";\". ++        semi             :: ParsecT s u m String,++        -- | Lexeme parser @comma@ parses the character \',\' and skips any+        -- trailing white space. Returns the string \",\". ++        comma            :: ParsecT s u m String,++        -- | Lexeme parser @colon@ parses the character \':\' and skips any+        -- trailing white space. Returns the string \":\". ++        colon            :: ParsecT s u m String,++        -- | Lexeme parser @dot@ parses the character \'.\' and skips any+        -- trailing white space. Returns the string \".\". ++        dot              :: ParsecT s u m String,++        -- | Lexeme parser @semiSep p@ parses /zero/ or more occurrences of @p@+        -- separated by 'semi'. Returns a list of values returned by+        -- @p@.++        semiSep          :: forall a . ParsecT s u m a -> ParsecT s u m [a],++        -- | Lexeme parser @semiSep1 p@ parses /one/ or more occurrences of @p@+        -- separated by 'semi'. Returns a list of values returned by @p@. ++        semiSep1         :: forall a . ParsecT s u m a -> ParsecT s u m [a],++        -- | Lexeme parser @commaSep p@ parses /zero/ or more occurrences of+        -- @p@ separated by 'comma'. Returns a list of values returned+        -- by @p@. ++        commaSep         :: forall a . ParsecT s u m a -> ParsecT s u m [a],++        -- | Lexeme parser @commaSep1 p@ parses /one/ or more occurrences of+        -- @p@ separated by 'comma'. Returns a list of values returned+        -- by @p@. ++        commaSep1        :: forall a . ParsecT s u m a -> ParsecT s u m [a]+    }++-----------------------------------------------------------+-- Given a LanguageDef, create a token parser.+-----------------------------------------------------------++-- | The expression @makeTokenParser language@ creates a 'GenTokenParser'+-- record that contains lexical parsers that are+-- defined using the definitions in the @language@ record.+--+-- The use of this function is quite stylized - one imports the+-- appropiate language definition and selects the lexical parsers that+-- are needed from the resulting 'GenTokenParser'.+--+-- >  module Main where+-- >+-- >  import Text.Parsec+-- >  import qualified Text.Parsec.Token as P+-- >  import Text.Parsec.Language (haskellDef)+-- >+-- >  -- The parser+-- >  ...+-- >+-- >  expr  =   parens expr+-- >        <|> identifier+-- >        <|> ...+-- >       +-- >+-- >  -- The lexer+-- >  lexer       = P.makeTokenParser haskellDef    +-- >      +-- >  parens      = P.parens lexer+-- >  braces      = P.braces lexer+-- >  identifier  = P.identifier lexer+-- >  reserved    = P.reserved lexer+-- >  ...++makeTokenParser :: (Stream s m Char)+                => GenLanguageDef s u m -> GenTokenParser s u m+makeTokenParser languageDef+    = TokenParser{ identifier = identifier+                 , reserved = reserved+                 , operator = operator+                 , reservedOp = reservedOp++                 , charLiteral = charLiteral+                 , stringLiteral = stringLiteral+                 , natural = natural+                 , integer = integer+                 , float = float+                 , naturalOrFloat = naturalOrFloat+                 , decimal = decimal+                 , hexadecimal = hexadecimal+                 , octal = octal++                 , symbol = symbol+                 , lexeme = lexeme+                 , whiteSpace = whiteSpace++                 , parens = parens+                 , braces = braces+                 , angles = angles+                 , brackets = brackets+                 , squares = brackets+                 , semi = semi+                 , comma = comma+                 , colon = colon+                 , dot = dot+                 , semiSep = semiSep+                 , semiSep1 = semiSep1+                 , commaSep = commaSep+                 , commaSep1 = commaSep1+                 }+    where++    -----------------------------------------------------------+    -- Bracketing+    -----------------------------------------------------------+    parens p        = between (symbol "(") (symbol ")") p+    braces p        = between (symbol "{") (symbol "}") p+    angles p        = between (symbol "<") (symbol ">") p+    brackets p      = between (symbol "[") (symbol "]") p++    semi            = symbol ";"+    comma           = symbol ","+    dot             = symbol "."+    colon           = symbol ":"++    commaSep p      = sepBy p comma+    semiSep p       = sepBy p semi++    commaSep1 p     = sepBy1 p comma+    semiSep1 p      = sepBy1 p semi+++    -----------------------------------------------------------+    -- Chars & Strings+    -----------------------------------------------------------+    charLiteral     = lexeme (between (char '\'')+                                      (char '\'' <?> "end of character")+                                      characterChar )+                    <?> "character"++    characterChar   = charLetter <|> charEscape+                    <?> "literal character"++    charEscape      = do{ char '\\'; escapeCode }+    charLetter      = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))++++    stringLiteral   = lexeme (+                      do{ str <- between (char '"')+                                         (char '"' <?> "end of string")+                                         (many stringChar)+                        ; return (foldr (maybe id (:)) "" str)+                        }+                      <?> "literal string")++    stringChar      =   do{ c <- stringLetter; return (Just c) }+                    <|> stringEscape+                    <?> "string character"++    stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++    stringEscape    = do{ char '\\'+                        ;     do{ escapeGap  ; return Nothing }+                          <|> do{ escapeEmpty; return Nothing }+                          <|> do{ esc <- escapeCode; return (Just esc) }+                        }++    escapeEmpty     = char '&'+    escapeGap       = do{ many1 space+                        ; char '\\' <?> "end of string gap"+                        }++++    -- escape codes+    escapeCode      = charEsc <|> charNum <|> charAscii <|> charControl+                    <?> "escape code"++    charControl     = do{ char '^'+                        ; code <- upper+                        ; return (toEnum (fromEnum code - fromEnum 'A'))+                        }++    charNum         = do{ code <- decimal+                                  <|> do{ char 'o'; number 8 octDigit }+                                  <|> do{ char 'x'; number 16 hexDigit }+                        ; return (toEnum (fromInteger code))+                        }++    charEsc         = choice (map parseEsc escMap)+                    where+                      parseEsc (c,code)     = do{ char c; return code }++    charAscii       = choice (map parseAscii asciiMap)+                    where+                      parseAscii (asc,code) = try (do{ string asc; return code })+++    -- escape code tables+    escMap          = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")+    asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)++    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          = ['\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']+++    -----------------------------------------------------------+    -- Numbers+    -----------------------------------------------------------+    naturalOrFloat  = lexeme (natFloat) <?> "number"++    float           = lexeme floating   <?> "float"+    integer         = lexeme int        <?> "integer"+    natural         = lexeme nat        <?> "natural"+++    -- floats+    floating        = do{ n <- decimal+                        ; fractExponent n+                        }+++    natFloat        = do{ char '0'+                        ; zeroNumFloat+                        }+                      <|> decimalFloat++    zeroNumFloat    =  do{ n <- hexadecimal <|> octal+                         ; return (Left n)+                         }+                    <|> decimalFloat+                    <|> fractFloat 0+                    <|> return (Left 0)++    decimalFloat    = do{ n <- decimal+                        ; option (Left n)+                                 (fractFloat n)+                        }++    fractFloat n    = do{ f <- fractExponent n+                        ; return (Right f)+                        }++    fractExponent n = do{ fract <- fraction+                        ; expo  <- option 1.0 exponent'+                        ; return ((fromInteger n + fract)*expo)+                        }+                    <|>+                      do{ expo <- exponent'+                        ; return ((fromInteger n)*expo)+                        }++    fraction        = do{ char '.'+                        ; digits <- many1 digit <?> "fraction"+                        ; return (foldr op 0.0 digits)+                        }+                      <?> "fraction"+                    where+                      op d f    = (f + fromIntegral (digitToInt d))/10.0++    exponent'       = do{ oneOf "eE"+                        ; f <- sign+                        ; e <- decimal <?> "exponent"+                        ; return (power (f e))+                        }+                      <?> "exponent"+                    where+                       power e  | e < 0      = 1.0/power(-e)+                                | otherwise  = fromInteger (10^e)+++    -- integers and naturals+    int             = do{ f <- lexeme sign+                        ; n <- nat+                        ; return (f n)+                        }++    sign            =   (char '-' >> return negate)+                    <|> (char '+' >> return id)+                    <|> return id++    nat             = zeroNumber <|> decimal++    zeroNumber      = do{ char '0'+                        ; hexadecimal <|> octal <|> decimal <|> return 0+                        }+                      <?> ""++    decimal         = number 10 digit+    hexadecimal     = do{ oneOf "xX"; number 16 hexDigit }+    octal           = do{ oneOf "oO"; number 8 octDigit  }++    number base baseDigit+        = do{ digits <- many1 baseDigit+            ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+            ; seq n (return n)+            }++    -----------------------------------------------------------+    -- Operators & reserved ops+    -----------------------------------------------------------+    reservedOp name =+        lexeme $ try $+        do{ string name+          ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)+          }++    operator =+        lexeme $ try $+        do{ name <- oper+          ; if (isReservedOp name)+             then unexpected ("reserved operator " ++ show name)+             else return name+          }++    oper =+        do{ c <- (opStart languageDef)+          ; cs <- many (opLetter languageDef)+          ; return (c:cs)+          }+        <?> "operator"++    isReservedOp name =+        isReserved (sort (reservedOpNames languageDef)) name+++    -----------------------------------------------------------+    -- Identifiers & Reserved words+    -----------------------------------------------------------+    reserved name =+        lexeme $ try $+        do{ caseString name+          ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)+          }++    caseString name+        | caseSensitive languageDef  = string name+        | otherwise               = do{ walk name; return name }+        where+          walk []     = return ()+          walk (c:cs) = do{ caseChar c <?> msg; walk cs }++          caseChar c  | isAlpha c  = char (toLower c) <|> char (toUpper c)+                      | otherwise  = char c++          msg         = show name+++    identifier =+        lexeme $ try $+        do{ name <- ident+          ; if (isReservedName name)+             then unexpected ("reserved word " ++ show name)+             else return name+          }+++    ident+        = do{ c <- identStart languageDef+            ; cs <- many (identLetter languageDef)+            ; return (c:cs)+            }+        <?> "identifier"++    isReservedName name+        = isReserved theReservedNames caseName+        where+          caseName      | caseSensitive languageDef  = name+                        | otherwise               = map toLower name+++    isReserved names name+        = scan names+        where+          scan []       = False+          scan (r:rs)   = case (compare r name) of+                            LT  -> scan rs+                            EQ  -> True+                            GT  -> False++    theReservedNames+        | caseSensitive languageDef  = sortedNames+        | otherwise               = map (map toLower) sortedNames+        where+          sortedNames   = sort (reservedNames languageDef)++++    -----------------------------------------------------------+    -- White space & symbols+    -----------------------------------------------------------+    symbol name+        = lexeme (string name)++    lexeme p+        = do{ x <- p; whiteSpace; return x  }+++    --whiteSpace+    whiteSpace+        | noLine && noMulti  = skipMany (simpleSpace <?> "")+        | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")+        | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")+        | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")+        where+          noLine  = null (commentLine languageDef)+          noMulti = null (commentStart languageDef)+++    simpleSpace =+        skipMany1 (satisfy isSpace)++    oneLineComment =+        do{ try (string (commentLine languageDef))+          ; skipMany (satisfy (/= '\n'))+          ; return ()+          }++    multiLineComment =+        do { try (string (commentStart languageDef))+           ; inComment+           }++    inComment+        | nestedComments languageDef  = inCommentMulti+        | otherwise                = inCommentSingle++    inCommentMulti+        =   do{ try (string (commentEnd languageDef)) ; return () }+        <|> do{ multiLineComment                     ; inCommentMulti }+        <|> do{ skipMany1 (noneOf startEnd)          ; inCommentMulti }+        <|> do{ oneOf startEnd                       ; inCommentMulti }+        <?> "end of comment"+        where+          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)++    inCommentSingle+        =   do{ try (string (commentEnd languageDef)); return () }+        <|> do{ skipMany1 (noneOf startEnd)         ; inCommentSingle }+        <|> do{ oneOf startEnd                      ; inCommentSingle }+        <?> "end of comment"+        where+          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)
Text/ParserCombinators/Parsec.hs view
@@ -1,54 +1,41 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional -- Portability :  portable------ Parsec, the Fast Monadic Parser combinator library, see--- <http://www.cs.uu.nl/people/daan/parsec.html>.------ Inspired by:------ * Graham Hutton and Erik Meijer:---   Monadic Parser Combinators.---   Technical report NOTTCS-TR-96-4. ---   Department of Computer Science, University of Nottingham, 1996. ---   <http://www.cs.nott.ac.uk/~gmh/monparsing.ps>------ * Andrew Partridge, David Wright: ---   Predictive parser combinators need four values to report errors.---   Journal of Functional Programming 6(2): 355-364, 1996------ This helper module exports elements from the basic libraries.---+-- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec-               ( -- complete modules-                 module Text.ParserCombinators.Parsec.Prim-               , module Text.ParserCombinators.Parsec.Combinator-               , module Text.ParserCombinators.Parsec.Char-               -               -- module Text.ParserCombinators.Parsec.Error-               , ParseError   -               , errorPos   -               -               -- module Text.ParserCombinators.Parsec.Pos-               , SourcePos-               , SourceName, Line, Column             -               , sourceName, sourceLine, sourceColumn             -               , incSourceLine, incSourceColumn-               , setSourceLine, setSourceColumn, setSourceName+    ( -- complete modules+      module Text.ParserCombinators.Parsec.Prim+    , module Text.ParserCombinators.Parsec.Combinator+    , module Text.ParserCombinators.Parsec.Char -             ) where+    -- module Text.ParserCombinators.Parsec.Error+    , ParseError+    , errorPos -import Text.ParserCombinators.Parsec.Pos            -- textual positions-import Text.ParserCombinators.Parsec.Error          -- parse errors-import Text.ParserCombinators.Parsec.Prim           -- primitive combinators-import Text.ParserCombinators.Parsec.Combinator     -- derived combinators-import Text.ParserCombinators.Parsec.Char           -- character parsers+    -- module Text.ParserCombinators.Parsec.Pos+    , SourcePos+    , SourceName, Line, Column+    , sourceName, sourceLine, sourceColumn+    , incSourceLine, incSourceColumn+    , setSourceLine, setSourceColumn, setSourceName +    ) where++import Text.Parsec.String()++import Text.ParserCombinators.Parsec.Prim+import Text.ParserCombinators.Parsec.Combinator+import Text.ParserCombinators.Parsec.Char++import Text.ParserCombinators.Parsec.Error+import Text.ParserCombinators.Parsec.Pos
Text/ParserCombinators/Parsec/Char.hs view
@@ -1,75 +1,40 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Char--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional -- Portability :  portable------ Commonly used character parsers. -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Char-                  ( CharParser-                  , spaces, space-                  , newline, tab-                  , upper, lower, alphaNum, letter-                  , digit, hexDigit, octDigit-                  , char, string-                  , anyChar, oneOf, noneOf-                  , satisfy-                  ) where+    ( CharParser,+      spaces,+      space,+      newline,+      tab,+      upper,+      lower,+      alphaNum,+      letter,+      digit,+      hexDigit,+      octDigit,+      char,+      string,+      anyChar,+      oneOf,+      noneOf,+      satisfy+    ) where -import Prelude-import Data.Char-import Text.ParserCombinators.Parsec.Pos( updatePosChar, updatePosString )-import Text.ParserCombinators.Parsec.Prim --------------------------------------------------------------- Type of character parsers-------------------------------------------------------------type CharParser st a    = GenParser Char st a---------------------------------------------------------------- Character parsers-------------------------------------------------------------oneOf, noneOf :: [Char] -> CharParser st Char-oneOf cs            = satisfy (\c -> elem c cs)-noneOf cs           = satisfy (\c -> not (elem c cs))--spaces :: CharParser st ()-spaces              = skipMany space        <?> "white space"          --space, newline, tab :: CharParser st Char-space               = satisfy (isSpace)     <?> "space"-newline             = char '\n'             <?> "new-line"-tab                 = char '\t'             <?> "tab"--upper, lower, alphaNum, letter, digit, hexDigit, octDigit :: CharParser st Char-upper               = satisfy (isUpper)     <?> "uppercase letter"-lower               = satisfy (isLower)     <?> "lowercase letter"-alphaNum            = satisfy (isAlphaNum)  <?> "letter or digit"-letter              = satisfy (isAlpha)     <?> "letter"-digit               = satisfy (isDigit)     <?> "digit"-hexDigit            = satisfy (isHexDigit)  <?> "hexadecimal digit"-octDigit            = satisfy (isOctDigit)  <?> "octal digit"--char :: Char -> CharParser st Char-char c              = satisfy (==c)  <?> show [c]--anyChar :: CharParser st Char-anyChar             = satisfy (const True)---------------------------------------------------------------- Primitive character parsers-------------------------------------------------------------satisfy :: (Char -> Bool) -> CharParser st Char-satisfy f           = tokenPrim (\c -> show [c]) -                                (\pos c cs -> updatePosChar pos c) -                                (\c -> if f c then Just c else Nothing)+import Text.Parsec.Char+import Text.Parsec.String -string :: String -> CharParser st String-string s            = tokens show updatePosString s+type CharParser st = GenParser Char st
Text/ParserCombinators/Parsec/Combinator.hs view
@@ -1,155 +1,42 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Combinator--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional -- Portability :  portable------ Commonly used generic combinators -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Combinator-                        ( choice-                        , count-                        , between-                        , option, optionMaybe, optional-                        , skipMany1-                        , many1-                        , sepBy, sepBy1-                        , endBy, endBy1-                        , sepEndBy, sepEndBy1-                        , chainl, chainl1-                        , chainr, chainr1-                        , eof, notFollowedBy-                        -                        -- tricky combinators-                        , manyTill, lookAhead, anyToken-                        ) where--import Control.Monad-import Text.ParserCombinators.Parsec.Prim----------------------------------------------------------------------------------------------------------------------------------------choice :: [GenParser tok st a] -> GenParser tok st a-choice ps           = foldr (<|>) mzero ps--option :: a -> GenParser tok st a -> GenParser tok st a-option x p          = p <|> return x--optionMaybe :: GenParser tok st a -> GenParser tok st (Maybe a)-optionMaybe p       = option Nothing (liftM Just p)--optional :: GenParser tok st a -> GenParser tok st ()-optional p          = do{ p; return ()} <|> return ()--between :: GenParser tok st open -> GenParser tok st close -            -> GenParser tok st a -> GenParser tok st a-between open close p-                    = do{ open; x <- p; close; return x }-                -                -skipMany1 :: GenParser tok st a -> GenParser tok st ()-skipMany1 p         = do{ p; skipMany p }-{--skipMany p          = scan-                    where-                      scan  = do{ p; scan } <|> return ()--}--many1 :: GenParser tok st a -> GenParser tok st [a]-many1 p             = do{ x <- p; xs <- many p; return (x:xs) }-{--many p              = scan id-                    where-                      scan f    = do{ x <- p-                                    ; scan (\tail -> f (x:tail))-                                    }-                                <|> return (f [])--}--sepBy1,sepBy :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a]-sepBy p sep         = sepBy1 p sep <|> return []-sepBy1 p sep        = do{ x <- p-                        ; xs <- many (sep >> p)-                        ; return (x:xs)-                        }--sepEndBy1, sepEndBy :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a]-sepEndBy1 p sep     = do{ x <- p-                        ; do{ sep-                            ; xs <- sepEndBy p sep-                            ; return (x:xs)-                            }-                          <|> return [x]-                        }-        -sepEndBy p sep      = sepEndBy1 p sep <|> return []---endBy1,endBy :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a]-endBy1 p sep        = many1 (do{ x <- p; sep; return x })-endBy p sep         = many (do{ x <- p; sep; return x })--count :: Int -> GenParser tok st a -> GenParser tok st [a]-count n p           | n <= 0    = return []-                    | otherwise = sequence (replicate n p)---chainr,chainl :: GenParser tok st a -> GenParser tok st (a -> a -> a) -> a -> GenParser tok st a-chainr p op x       = chainr1 p op <|> return x-chainl p op x       = chainl1 p op <|> return x--chainr1,chainl1 :: GenParser tok st a -> GenParser tok st (a -> a -> a) -> GenParser tok st a-chainl1 p op        = do{ x <- p; rest x }-                    where-                      rest x    = do{ f <- op-                                    ; y <- p-                                    ; rest (f x y)-                                    }-                                <|> return x-                              -chainr1 p op        = scan-                    where-                      scan      = do{ x <- p; rest x }-                      -                      rest x    = do{ f <- op-                                    ; y <- scan-                                    ; return (f x y)-                                    }-                                <|> return x---------------------------------------------------------------- Tricky combinators-------------------------------------------------------------anyToken :: Show tok => GenParser tok st tok-anyToken            = tokenPrim show (\pos tok toks -> pos) Just--eof :: Show tok => GenParser tok st ()-eof                 = notFollowedBy anyToken <?> "end of input"   --notFollowedBy :: Show tok => GenParser tok st tok -> GenParser tok st ()   -notFollowedBy p     = try (do{ c <- p; unexpected (show [c]) }-                           <|> return ()-                          )--manyTill :: GenParser tok st a -> GenParser tok st end -> GenParser tok st [a]-manyTill p end      = scan-                    where-                      scan  = do{ end; return [] }-                            <|>-                              do{ x <- p; xs <- scan; return (x:xs) }+    ( choice,+      count,+      between,+      option,+      optionMaybe,+      optional,+      skipMany1,+      many1,+      sepBy,+      sepBy1,+      endBy,+      endBy1,+      sepEndBy,+      sepEndBy1,+      chainl,+      chainl1,+      chainr,+      chainr1,+      eof,+      notFollowedBy,+      manyTill,+      lookAhead,+      anyToken+    ) where  -lookAhead :: GenParser tok st a -> GenParser tok st a-lookAhead p         = do{ state <- getParserState-                        ; x <- p-                        ; setParserState state-                        ; return x-                        }+import Text.Parsec.Combinator
Text/ParserCombinators/Parsec/Error.hs view
@@ -1,164 +1,40 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Error--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional -- Portability :  portable------ Parse errors -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Error-                  ( Message(SysUnExpect,UnExpect,Expect,Message)-                  , messageString, messageCompare, messageEq-                  -                  , ParseError, errorPos, errorMessages, errorIsUnknown-                  , showErrorMessages-                  -                  , newErrorMessage, newErrorUnknown-                  , addErrorMessage, setErrorPos, setErrorMessage-                  , mergeError-                  )-                  where+    ( Message (SysUnExpect,UnExpect,Expect,Message),+      messageString,+      messageCompare,+      messageEq,+      ParseError,+      errorPos,+      errorMessages,+      errorIsUnknown,+      showErrorMessages,+      newErrorMessage,+      newErrorUnknown,+      addErrorMessage,+      setErrorPos,+      setErrorMessage,+      mergeError+    ) where +import Text.Parsec.Error -import Prelude-import Data.List (nub,sortBy)-import Text.ParserCombinators.Parsec.Pos -                          --------------------------------------------------------------- Messages------------------------------------------------------------                         -data Message        = SysUnExpect !String   --library generated unexpect            -                    | UnExpect    !String   --unexpected something     -                    | Expect      !String   --expecting something-                    | Message     !String   --raw message-                    -messageToEnum msg-    = case msg of SysUnExpect _ -> 0-                  UnExpect _    -> 1-                  Expect _      -> 2-                  Message _     -> 3                                  -                                      + messageCompare :: Message -> Message -> Ordering-messageCompare msg1 msg2-    = compare (messageToEnum msg1) (messageToEnum msg2)-  -messageString :: Message -> String-messageString msg-    = case msg of SysUnExpect s -> s-                  UnExpect s    -> s-                  Expect s      -> s-                  Message s     -> s                                  +messageCompare = compare  messageEq :: Message -> Message -> Bool-messageEq msg1 msg2-    = (messageCompare msg1 msg2 == EQ)-    -    --------------------------------------------------------------- Parse Errors------------------------------------------------------------                           -data ParseError     = ParseError !SourcePos [Message]--errorPos :: ParseError -> SourcePos-errorPos (ParseError pos msgs)-    = pos-                  -errorMessages :: ParseError -> [Message]-errorMessages (ParseError pos msgs)-    = sortBy messageCompare msgs      -        -errorIsUnknown :: ParseError -> Bool-errorIsUnknown (ParseError pos msgs)-    = null msgs-            -            --------------------------------------------------------------- Create parse errors------------------------------------------------------------                         -newErrorUnknown :: SourcePos -> ParseError-newErrorUnknown pos-    = ParseError pos []-    -newErrorMessage :: Message -> SourcePos -> ParseError-newErrorMessage msg pos  -    = ParseError pos [msg]--addErrorMessage :: Message -> ParseError -> ParseError-addErrorMessage msg (ParseError pos msgs)-    = ParseError pos (msg:msgs)-    -setErrorPos :: SourcePos -> ParseError -> ParseError-setErrorPos pos (ParseError _ msgs)-    = ParseError pos msgs-    -setErrorMessage :: Message -> ParseError -> ParseError-setErrorMessage msg (ParseError pos msgs)-    = ParseError pos (msg:filter (not . messageEq msg) msgs)- -    -mergeError :: ParseError -> ParseError -> ParseError-mergeError (ParseError pos msgs1) (ParseError _ msgs2)-    = ParseError pos (msgs1 ++ msgs2)-    ----------------------------------------------------------------- Show Parse Errors------------------------------------------------------------                         -instance Show ParseError where-  show err-    = show (errorPos err) ++ ":" ++ -      showErrorMessages "or" "unknown parse error" -                        "expecting" "unexpected" "end of input"-                       (errorMessages err)----- | Language independent show function-showErrorMessages ::-    String -> String -> String -> String -> String -> [Message] -> String-showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs-    | null msgs = msgUnknown-    | otherwise = concat $ map ("\n"++) $ clean $-                 [showSysUnExpect,showUnExpect,showExpect,showMessages]-    where-      (sysUnExpect,msgs1)   = span (messageEq (SysUnExpect "")) msgs-      (unExpect,msgs2)      = span (messageEq (UnExpect "")) msgs1-      (expect,messages)     = span (messageEq (Expect "")) msgs2-    -      showExpect        = showMany msgExpecting expect-      showUnExpect      = showMany msgUnExpected unExpect-      showSysUnExpect   | not (null unExpect) ||-                          null sysUnExpect       = ""-                        | null firstMsg          = msgUnExpected ++ " " ++ msgEndOfInput-                        | otherwise              = msgUnExpected ++ " " ++ firstMsg-                        where-                          firstMsg  = messageString (head sysUnExpect)-                        -      showMessages      = showMany "" messages--      -      --helpers                                                                                                                                        -      showMany pre msgs = case (clean (map messageString msgs)) of-                            [] -> ""-                            ms | null pre  -> commasOr ms-                               | otherwise -> pre ++ " " ++ commasOr ms-                            -      commasOr []       = ""                -      commasOr [m]      = m                -      commasOr ms       = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms-        -      commaSep          = seperate ", " . clean-      semiSep           = seperate "; " . clean       -        -      seperate sep []   = ""-      seperate sep [m]  = m-      seperate sep (m:ms) = m ++ sep ++ seperate sep ms                            -      -      clean             = nub . filter (not.null)                  -      +messageEq = (==)
Text/ParserCombinators/Parsec/Expr.hs view
@@ -1,123 +1,40 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Expr--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional -- Portability :  portable------ A helper module to parse \"expressions\".--- Builds a parser given a table of operators and associativities. -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Expr-                 ( Assoc(..), Operator(..), OperatorTable-                 , buildExpressionParser-                 ) where--import Text.ParserCombinators.Parsec.Prim-import Text.ParserCombinators.Parsec.Combinator-+    ( Assoc (AssocNone,AssocLeft,AssocRight),+      Operator(..),+      OperatorTable,+      buildExpressionParser+    ) where --------------------------------------------------------------- Assoc and OperatorTable-------------------------------------------------------------data Assoc                = AssocNone -                          | AssocLeft-                          | AssocRight-                        -data Operator t st a      = Infix (GenParser t st (a -> a -> a)) Assoc-                          | Prefix (GenParser t st (a -> a))-                          | Postfix (GenParser t st (a -> a))+import Text.Parsec.Expr(Assoc(..))+import qualified Text.Parsec.Expr as N+import Text.ParserCombinators.Parsec(GenParser) -type OperatorTable t st a = [[Operator t st a]]+import Control.Monad.Identity +data Operator tok st a   = Infix  (GenParser tok st (a -> a -> a)) Assoc+                         | Prefix (GenParser tok st (a -> a)) +type OperatorTable tok st a = [[Operator tok st a]] --------------------------------------------------------------- Convert an OperatorTable and basic term parser into--- a full fledged expression parser-------------------------------------------------------------buildExpressionParser :: OperatorTable tok st a -> GenParser tok st a -> GenParser tok st 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 $-                                  do{ 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  <- do{ z <- termP; rassocP1 z }-                             ; 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"-                 }-                +convert :: Operator tok st a -> N.Operator [tok] st Identity a+convert (Infix p a) = N.Infix p a+convert (Prefix p)  = N.Prefix p -      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)-      +buildExpressionParser :: OperatorTable tok st a+                      -> GenParser tok st a+                      -> GenParser tok st a+buildExpressionParser = N.buildExpressionParser . map (map convert)
Text/ParserCombinators/Parsec/Language.hs view
@@ -1,124 +1,28 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Language--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional--- Portability :  non-portable (uses non-portable module Text.ParserCombinators.Parsec.Token)------ A helper module that defines some language definitions that can be used--- to instantiate a token parser (see "Text.ParserCombinators.Parsec.Token").+-- Portability :  portable -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Language-                     ( haskellDef, haskell-                     , mondrianDef, mondrian-                   -                     , emptyDef-                     , haskellStyle-                     , javaStyle   -                     , LanguageDef (..)                -                     ) where-import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Token --           --------------------------------------------------------------- Styles: haskellStyle, javaStyle------------------------------------------------------------               -haskellStyle :: LanguageDef st-haskellStyle= emptyDef                      -                { commentStart   = "{-"-                , commentEnd     = "-}"-                , commentLine    = "--"-                , nestedComments = True-                , identStart     = letter-                , identLetter	 = alphaNum <|> oneOf "_'"-                , opStart	 = opLetter haskellStyle-                , opLetter	 = oneOf ":!#$%&*+./<=>?@\\^|-~"              -                , reservedOpNames= []-                , reservedNames  = []-                , caseSensitive  = True                                   -                }         -                           -javaStyle  :: LanguageDef st-javaStyle   = emptyDef-		{ commentStart	 = "/*"-		, commentEnd	 = "*/"-		, commentLine	 = "//"-		, nestedComments = True-		, identStart	 = letter-		, identLetter	 = alphaNum <|> oneOf "_'"		-		, reservedNames  = []-		, reservedOpNames= []	-                , caseSensitive  = False				  -		}---------------------------------------------------------------- minimal language definition------------------------------------------------------------                -emptyDef   :: LanguageDef st-emptyDef    = LanguageDef -               { commentStart   = ""-               , commentEnd     = ""-               , commentLine    = ""-               , nestedComments = True-               , identStart     = letter <|> char '_'-               , identLetter    = alphaNum <|> oneOf "_'"-               , opStart        = opLetter emptyDef-               , opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~"-               , reservedOpNames= []-               , reservedNames  = []-               , caseSensitive  = True-               }-                ----------------------------------------------------------------- Haskell------------------------------------------------------------               -haskell :: TokenParser st-haskell      = makeTokenParser haskellDef--haskellDef  :: LanguageDef st-haskellDef   = haskell98Def-	        { identLetter	 = identLetter haskell98Def <|> char '#'-	        , reservedNames	 = reservedNames haskell98Def ++ -    				   ["foreign","import","export","primitive"-    				   ,"_ccall_","_casm_"-    				   ,"forall"-    				   ]-                }-			    -haskell98Def :: LanguageDef st-haskell98Def = haskellStyle-                { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"]-                , reservedNames  = ["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"-                                   ]-                }         -                -                --------------------------------------------------------------- Mondrian------------------------------------------------------------               -mondrian :: TokenParser st-mondrian    = makeTokenParser mondrianDef--mondrianDef :: LanguageDef st-mondrianDef = javaStyle-		{ reservedNames = [ "case", "class", "default", "extends"-				  , "import", "in", "let", "new", "of", "package"-				  ]	-                , caseSensitive  = True				  -		}+    ( haskellDef,+      haskell,+      mondrianDef,+      mondrian,+      emptyDef,+      haskellStyle,+      javaStyle,+      LanguageDef,+      GenLanguageDef(..),+    ) where -				+import Text.Parsec.Token+import Text.Parsec.Language
Text/ParserCombinators/Parsec/Perm.hs view
@@ -1,122 +1,24 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Perm--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional--- Portability :  non-portable (uses existentially quantified data constructors)------ This module implements permutation parsers. The algorithm used--- is fairly complex since we push the type system to its limits :-)--- 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.+-- Portability :  portable -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Perm-                  ( PermParser  -- abstract--                  , permute-                  , (<||>), (<$$>)-                  , (<|?>), (<$?>)-                  ) where--import Text.ParserCombinators.Parsec--{--------------------------------------------------------------------------------------------------------------------------------}-infixl 1 <||>, <|?>-infixl 2 <$$>, <$?>---{----------------------------------------------------------------  test -- parse a permutation of -  * an optional string of 'a's-  * a required 'b'-  * an optional 'c'----------------------------------------------------------------}-test input-  = parse (do{ x <- ptest; eof; return x }) "" input--ptest :: Parser (String,Char,Char)-ptest  -  = permute $-    (,,) <$?> ("",many1 (char 'a'))-         <||> char 'b' -         <|?> ('_',char 'c')---{----------------------------------------------------------------  Building a permutation parser----------------------------------------------------------------}-(<||>) :: PermParser tok st (a -> b) -> GenParser tok st a -> PermParser tok st b-(<||>) perm p     = add perm p                  --(<$$>) :: (a -> b) -> GenParser tok st a -> PermParser tok st b-(<$$>) f p        = newperm f <||> p--(<|?>) :: PermParser tok st (a -> b) -> (a, GenParser tok st a) -> PermParser tok st b-(<|?>) perm (x,p) = addopt perm x p--(<$?>) :: (a -> b) -> (a, GenParser tok st a) -> PermParser tok st b-(<$?>) f (x,p)    = newperm f <|?> (x,p)----{----------------------------------------------------------------  The permutation tree----------------------------------------------------------------}-data PermParser tok st a = Perm (Maybe a) [Branch tok st a]-data Branch tok st a     = forall b. Branch (PermParser tok st (b -> a)) (GenParser tok st b)----- transform a permutation tree into a normal parser-permute :: PermParser tok st a -> GenParser tok st a-permute (Perm def xs)-  = choice (map branch xs ++ empty)-  where-    empty-      = case def of-          Nothing -> []-          Just x  -> [return x]--    branch (Branch perm p)-      = do{ x <- p-          ; f <- permute perm-          ; return (f x)-          }---- build permutation trees-newperm :: (a -> b) -> PermParser tok st (a -> b)-newperm f-  = Perm (Just f) []--add :: PermParser tok st (a -> b) -> GenParser tok st a -> PermParser tok st b-add perm@(Perm mf fs) p-  = Perm Nothing (first:map insert fs)-  where-    first   = Branch perm p-    insert (Branch perm' p')-            = Branch (add (mapPerms flip perm') p) p'--addopt :: PermParser tok st (a -> b) -> a -> GenParser tok st a -> PermParser tok st b-addopt perm@(Perm mf fs) x p-  = Perm (fmap ($ x) mf) (first:map insert fs)-  where-    first   = Branch perm p-    insert (Branch perm' p')-            = Branch (addopt (mapPerms flip perm') x p) p'-+    ( PermParser,+      permute,+      (<||>),+      (<$$>),+      (<|?>),+      (<$?>)+    ) where -mapPerms :: (a -> b) -> PermParser tok st a -> PermParser tok st b-mapPerms f (Perm x xs)-  = Perm (fmap f x) (map (mapBranch f) xs)-  where-    mapBranch f (Branch perm p)-      = Branch (mapPerms (f.) perm) p+import Text.Parsec.Perm
Text/ParserCombinators/Parsec/Pos.hs view
@@ -1,99 +1,35 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Pos--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional -- Portability :  portable------ Textual source positions. -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Pos-                  ( SourceName, Line, Column                 -                  , SourcePos-                  , sourceLine, sourceColumn, sourceName-                  , incSourceLine, incSourceColumn-                  , setSourceLine, setSourceColumn, setSourceName-                  , newPos, initialPos-                  , updatePosChar, updatePosString-                  ) where---------------------------------------------------------------- Source Positions, a file name, a line and a column.--- upper left is (1,1)------------------------------------------------------------                         -type SourceName     = String-type Line           = Int-type Column         = Int--data SourcePos      = SourcePos SourceName !Line !Column-		     deriving (Eq,Ord)-		--newPos :: SourceName -> Line -> Column -> SourcePos-newPos sourceName line column-    = SourcePos sourceName line column--initialPos :: SourceName -> SourcePos-initialPos sourceName-    = newPos sourceName 1 1--sourceName :: SourcePos -> SourceName-sourceName (SourcePos name line column) = name --sourceLine :: SourcePos -> Line-sourceLine (SourcePos name line column) = line--sourceColumn :: SourcePos -> Column-sourceColumn (SourcePos name line column) = column--incSourceLine :: SourcePos -> Line -> SourcePos-incSourceLine (SourcePos name line column) n = SourcePos name (line+n) column--incSourceColumn :: SourcePos -> Column -> SourcePos-incSourceColumn (SourcePos name line column) n = SourcePos name line (column+n)--setSourceName :: SourcePos -> SourceName -> SourcePos-setSourceName (SourcePos name line column) n = SourcePos n line column--setSourceLine :: SourcePos -> Line -> SourcePos-setSourceLine (SourcePos name line column) n = SourcePos name n column--setSourceColumn :: SourcePos -> Column -> SourcePos-setSourceColumn (SourcePos name line column) n = SourcePos name line n---------------------------------------------------------------- Update source positions on characters-------------------------------------------------------------updatePosString :: SourcePos -> String -> SourcePos-updatePosString pos string-    = forcePos (foldl updatePosChar pos string)--updatePosChar   :: SourcePos -> Char -> SourcePos-updatePosChar pos@(SourcePos name line column) c   -    = forcePos $-      case c of-        '\n' -> SourcePos name (line+1) 1-        '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8))-        _    -> SourcePos name line (column + 1)-        --forcePos :: SourcePos -> SourcePos      -forcePos pos@(SourcePos name line column)-    = seq line (seq column (pos))+    ( SourceName,+      Line,+      Column,+      SourcePos,+      sourceLine,+      sourceColumn,+      sourceName,+      incSourceLine,+      incSourceColumn,+      setSourceLine,+      setSourceColumn,+      setSourceName,+      newPos,+      initialPos,+      updatePosChar,+      updatePosString+    ) where+       --------------------------------------------------------------- Show positions ------------------------------------------------------------                                                 -instance Show SourcePos where-  show (SourcePos name line column)-    | null name = showLineColumn-    | otherwise = "\"" ++ name ++ "\" " ++ showLineColumn-    where-      showLineColumn    = "(line " ++ show line ++-                          ", column " ++ show column ++-                          ")" +import Text.Parsec.Pos
Text/ParserCombinators/Parsec/Prim.hs view
@@ -1,456 +1,65 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Prim--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional -- Portability :  portable------ The primitive parser combinators. -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Prim-                   ( -- operators: label a parser, alternative-                     (<?>), (<|>)--                   -- basic types-                   , Parser, GenParser-                   , runParser, parse, parseFromFile, parseTest-                   -                   -- primitive parsers:-                   -- instance Functor Parser     : fmap-                   -- instance Monad Parser       : return, >>=, fail-                   -- instance MonadPlus Parser   : mzero (pzero), mplus (<|>)-                   , token, tokens, tokenPrim, tokenPrimEx-                   , try, label, labels, unexpected, pzero--                   -- primitive because of space behaviour-                   , many, skipMany-                                -                   -- user state manipulation-                   , getState, setState, updateState--                   -- state manipulation-                   , getPosition, setPosition-                   , getInput, setInput                   -                   , State(..), getParserState, setParserState -                 ) where--import Prelude-import Text.ParserCombinators.Parsec.Pos-import Text.ParserCombinators.Parsec.Error-import Control.Monad--{-# INLINE parsecMap    #-}-{-# INLINE parsecReturn #-}-{-# INLINE parsecBind   #-}-{-# INLINE parsecZero   #-}-{-# INLINE parsecPlus   #-}-{-# INLINE token        #-}-{-# INLINE tokenPrim    #-}---------------------------------------------------------------- Operators:--- <?>  gives a name to a parser (which is used in error messages)--- <|>  is the choice operator-------------------------------------------------------------infix  0 <?>-infixr 1 <|>--(<?>) :: GenParser tok st a -> String -> GenParser tok st a-p <?> msg           = label p msg--(<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a-p1 <|> p2           = mplus p1 p2----------------------------------------------------------------- User state combinators-------------------------------------------------------------getState :: GenParser tok st st-getState        = do{ state <- getParserState-                    ; return (stateUser state)-                    }--setState :: st -> GenParser tok st ()-setState st     = do{ updateParserState (\(State input pos _) -> State input pos st)-                    ; return ()-                    }--updateState :: (st -> st) -> GenParser tok st ()-updateState f   = do{ updateParserState (\(State input pos user) -> State input pos (f user))-                    ; return ()-                    }----------------------------------------------------------------- Parser state combinators-------------------------------------------------------------getPosition :: GenParser tok st SourcePos-getPosition         = do{ state <- getParserState; return (statePos state) }--getInput :: GenParser tok st [tok]-getInput            = do{ state <- getParserState; return (stateInput state) }---setPosition :: SourcePos -> GenParser tok st ()-setPosition pos     = do{ updateParserState (\(State input _ user) -> State input pos user)-                        ; return ()-                        }-                        -setInput :: [tok] -> GenParser tok st ()-setInput input      = do{ updateParserState (\(State _ pos user) -> State input pos user)-                        ; return ()-                        }--getParserState	    :: GenParser tok st (State tok st)-getParserState      =  updateParserState id    --setParserState	    :: State tok st -> GenParser tok st (State tok st)-setParserState st   = updateParserState (const st)------------------------------------------------------------------- Parser definition.--- GenParser tok st a:---  General parser for tokens of type "tok", ---  a user state "st" and a result type "a"-------------------------------------------------------------type Parser a           = GenParser Char () a--newtype GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a))-runP (Parser p)            = p--data Consumed a         = Consumed a                --input is consumed-                        | Empty !a                  --no input is consumed-                    -data Reply tok st a     = Ok !a !(State tok st) ParseError    --parsing succeeded with "a"-                        | Error ParseError                    --parsing failed--data State tok st       = State { stateInput :: [tok]-                                , statePos   :: !SourcePos-                                , stateUser  :: !st-                                }----------------------------------------------------------------- run a parser-------------------------------------------------------------parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)-parseFromFile p fname-    = do{ input <- readFile fname-        ; return (parse p fname input)-        }--parseTest :: Show a => GenParser tok () a -> [tok] -> IO ()-parseTest p input-    = case (runParser p () "" input) of-        Left err -> do{ putStr "parse error at "-                      ; print err-                      }-        Right x  -> print x---parse :: GenParser tok () a -> SourceName -> [tok] -> Either ParseError a-parse p name input-    = runParser p () name input---runParser :: GenParser tok st a -> st -> SourceName -> [tok] -> Either ParseError a-runParser p st name input-    = case parserReply (runP p (State input (initialPos name) st)) of-        Ok x _ _    -> Right x-        Error err   -> Left err--parserReply result     -    = case result of-        Consumed reply -> reply-        Empty reply    -> reply----------------------------------------------------------------- Functor: fmap-------------------------------------------------------------instance Functor (GenParser tok st) where-  fmap f p  = parsecMap f p--parsecMap :: (a -> b) -> GenParser tok st a -> GenParser tok st b-parsecMap f (Parser p)-    = Parser (\state -> -        case (p state) of-          Consumed reply -> Consumed (mapReply reply)-          Empty    reply -> Empty    (mapReply reply)-      )-    where-      mapReply reply-        = case reply of-            Ok x state err -> let fx = f x -                              in seq fx (Ok fx state err)-            Error err      -> Error err-           ---------------------------------------------------------------- Monad: return, sequence (>>=) and fail------------------------------------------------------------    -instance Monad (GenParser tok st) where-  return x   = parsecReturn x  -  p >>= f    = parsecBind p f-  fail msg   = parsecFail msg--parsecReturn :: a -> GenParser tok st a-parsecReturn x-  = Parser (\state -> Empty (Ok x state (unknownError state)))   --parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b-parsecBind (Parser p) f-    = Parser (\state ->-        case (p state) of                 -          Consumed reply1 -            -> Consumed $-               case (reply1) of-                 Ok x state1 err1 -> case runP (f x) state1 of-                                       Empty reply2    -> mergeErrorReply err1 reply2-                                       Consumed reply2 -> reply2-                 Error err1       -> Error err1--          Empty reply1    -            -> case (reply1) of-                 Ok x state1 err1 -> case runP (f x) state1 of-                                       Empty reply2 -> Empty (mergeErrorReply err1 reply2)-                                       other        -> other                                                    -                 Error err1       -> Empty (Error err1)-      )                                                              --mergeErrorReply err1 reply-  = case reply of-      Ok x state err2 -> Ok x state (mergeError err1 err2)-      Error err2      -> Error (mergeError err1 err2)---parsecFail :: String -> GenParser tok st a-parsecFail msg-  = Parser (\state -> -      Empty (Error (newErrorMessage (Message msg) (statePos state))))+    ( (<?>),+      (<|>),+      Parser,+      GenParser,+      runParser,+      parse,+      parseFromFile,+      parseTest,+      token,+      tokens,+      tokenPrim,+      tokenPrimEx,+      try,+      label,+      labels,+      unexpected,+      pzero,+      many,+      skipMany,+      getState,+      setState,+      updateState,+      getPosition,+      setPosition,+      getInput,+      setInput,+      State(..),+      getParserState,+      setParserState+    ) where +import Text.Parsec.Prim hiding (runParser, try)+import qualified Text.Parsec.Prim as N -- 'N' for 'New'+import Text.Parsec.String --------------------------------------------------------------- MonadPlus: alternative (mplus) and mzero-------------------------------------------------------------instance MonadPlus (GenParser tok st) where-  mzero         = parsecZero-  mplus p1 p2   = parsecPlus p1 p2-      +import Text.Parsec.Error+import Text.Parsec.Pos  pzero :: GenParser tok st a-pzero = parsecZero--parsecZero :: GenParser tok st a-parsecZero-    = Parser (\state -> Empty (Error (unknownError state)))--parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a-parsecPlus (Parser p1) (Parser p2)-    = Parser (\state ->-        case (p1 state) of        -          Empty (Error err) -> case (p2 state) of-                                 Empty reply -> Empty (mergeErrorReply err reply)-                                 consumed    -> consumed-          other             -> other-      )---{- --- variant that favors a consumed reply over an empty one, even it is not the first alternative.-          empty@(Empty reply) -> case reply of-                                   Error err ->-                                     case (p2 state) of-                                       Empty reply -> Empty (mergeErrorReply err reply)-                                       consumed    -> consumed-                                   ok ->-                                     case (p2 state) of-                                       Empty reply -> empty-                                       consumed    -> consumed-          consumed  -> consumed--}+pzero = parserZero +runParser :: GenParser tok st a+          -> st+          -> SourceName+          -> [tok]+          -> Either ParseError a+runParser = N.runParser --------------------------------------------------------------- Primitive Parsers: ---  try, token(Prim), label, unexpected and updateState------------------------------------------------------------ try :: GenParser tok st a -> GenParser tok st a-try (Parser p)-    = Parser (\state@(State input pos user) ->     -        case (p state) of-          Consumed (Error err)  -> Empty (Error (setErrorPos pos err))-          Consumed ok           -> Consumed ok    -- was: Empty ok-          empty                 -> empty-      )--     -token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a    -token show tokpos test-  = tokenPrim show nextpos test-  where-    nextpos _ _   (tok:toks)  = tokpos tok-    nextpos _ tok []          = tokpos tok--tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a-tokenPrim show nextpos test-    = tokenPrimEx show nextpos Nothing test---- | The most primitive token recogniser. The expression @tokenPrimEx show nextpos mbnextstate test@,--- recognises tokens when @test@ returns @Just x@ (and returns the value @x@). Tokens are shown in--- error messages using @show@. The position is calculated using @nextpos@, and finally, @mbnextstate@,--- can hold a function that updates the user state on every token recognised (nice to count tokens :-).--- The function is packed into a 'Maybe' type for performance reasons.-tokenPrimEx :: (tok -> String) -> -               (SourcePos -> tok -> [tok] -> SourcePos) -> -               Maybe (SourcePos -> tok -> [tok] -> st -> st) ->-               (tok -> Maybe a) -> -               GenParser tok st a-tokenPrimEx show nextpos mbNextState test-    = case mbNextState of-        Nothing -          -> Parser (\state@(State input pos user) -> -              case input of-                (c:cs) -> case test c of-                            Just x  -> let newpos   = nextpos pos c cs-                                           newstate = State cs newpos user-                                       in seq newpos $ seq newstate $ -                                          Consumed (Ok x newstate (newErrorUnknown newpos))-                            Nothing -> Empty (sysUnExpectError (show c) pos)-                []     -> Empty (sysUnExpectError "" pos)-             )-        Just nextState-          -> Parser (\state@(State input pos user) -> -              case input of-                (c:cs) -> case test c of-                            Just x  -> let newpos   = nextpos pos c cs-                                           newuser  = nextState pos c cs user-                                           newstate = State cs newpos newuser-                                       in seq newpos $ seq newstate $ -                                          Consumed (Ok x newstate (newErrorUnknown newpos))-                            Nothing -> Empty (sysUnExpectError (show c) pos)-                []     -> Empty (sysUnExpectError "" pos)-             )---label :: GenParser tok st a -> String -> GenParser tok st a    -label p msg-  = labels p [msg]--labels :: GenParser tok st a -> [String] -> GenParser tok st a-labels (Parser p) msgs-    = Parser (\state -> -        case (p state) of-          Empty reply -> Empty $ -                         case (reply) of-                           Error err        -> Error (setExpectErrors err msgs)-                           Ok x state1 err  | errorIsUnknown err -> reply-                                            | otherwise -> Ok x state1 (setExpectErrors err msgs)-          other       -> other-      )---updateParserState :: (State tok st -> State tok st) -> GenParser tok st (State tok st)-updateParserState f -    = Parser (\state -> let newstate = f state-                        in Empty (Ok state newstate (unknownError newstate)))-    -    -unexpected :: String -> GenParser tok st a-unexpected msg-    = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state))))-    --setExpectErrors err []         = setErrorMessage (Expect "") err-setExpectErrors err [msg]      = setErrorMessage (Expect msg) err-setExpectErrors err (msg:msgs) = foldr (\msg err -> addErrorMessage (Expect msg) err) -                                       (setErrorMessage (Expect msg) err) msgs--sysUnExpectError msg pos  = Error (newErrorMessage (SysUnExpect msg) pos)-unknownError state        = newErrorUnknown (statePos state)---------------------------------------------------------------- Parsers unfolded for space:--- if many and skipMany are not defined as primitives,--- they will overflow the stack on large inputs------------------------------------------------------------    -many :: GenParser tok st a -> GenParser tok st [a]-many p-  = do{ xs <- manyAccum (:) p-      ; return (reverse xs)-      }--skipMany :: GenParser tok st a -> GenParser tok st ()-skipMany p-  = do{ manyAccum (\x xs -> []) p-      ; return ()-      }--manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a]-manyAccum accum (Parser p)-  = Parser (\state -> -    let walk xs state r = case r of-                           Empty (Error err)          -> Ok xs state err-                           Empty ok                   -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."-                           Consumed (Error err)       -> Error err-                           Consumed (Ok x state' err) -> let ys = accum x xs-                                                         in seq ys (walk ys state' (p state'))-    in case (p state) of-         Empty reply  -> case reply of-                           Ok x state' err -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."-                           Error err       -> Empty (Ok [] state err)-         consumed     -> Consumed $ walk [] state consumed)------------------------------------------------------------------ Parsers unfolded for speed: ---  tokens------------------------------------------------------------    --{- specification of @tokens@:-tokens showss nextposs s-  = scan s-  where-    scan []       = return s-    scan (c:cs)   = do{ token show nextpos c <?> shows s; scan cs }                      --    show c        = shows [c]-    nextpos pos c = nextposs pos [c]--}--tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok]-tokens shows nextposs s-    = Parser (\state@(State input pos user) -> -       let-        ok cs             = let newpos   = nextposs pos s-                                newstate = State cs newpos user-                            in seq newpos $ seq newstate $ -                               (Ok s newstate (newErrorUnknown newpos))-                               -        errEof            = Error (setErrorMessage (Expect (shows s))-                                     (newErrorMessage (SysUnExpect "") pos))-        errExpect c       = Error (setErrorMessage (Expect (shows s))-                                     (newErrorMessage (SysUnExpect (shows [c])) pos))--        walk [] cs        = ok cs-        walk xs []        = errEof-        walk (x:xs) (c:cs)| x == c        = walk xs cs-                          | otherwise     = errExpect c--        walk1 [] cs        = Empty (ok cs)-        walk1 xs []        = Empty (errEof)-        walk1 (x:xs) (c:cs)| x == c        = Consumed (walk xs cs)-                           | otherwise     = Empty (errExpect c)--       in walk1 s input)--+try = N.try
Text/ParserCombinators/Parsec/Token.hs view
@@ -1,473 +1,23 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Text.ParserCombinators.Parsec.Token--- Copyright   :  (c) Daan Leijen 1999-2001--- License     :  BSD-style (see the file libraries/parsec/LICENSE)+-- Copyright   :  (c) Paolo Martini 2007+-- License     :  BSD-style (see the LICENSE file) -- --- Maintainer  :  daan@cs.uu.nl+-- Maintainer  :  derek.a.elkins@gmail.com -- Stability   :  provisional--- Portability :  non-portable (uses existentially quantified data constructors)------ A helper module to parse lexical elements (tokens).+-- Portability :  portable -- +-- Parsec compatibility module+--  -----------------------------------------------------------------------------  module Text.ParserCombinators.Parsec.Token-                  ( LanguageDef (..)-                  , TokenParser (..)-                  , makeTokenParser-                  ) where--import Data.Char (isAlpha,toLower,toUpper,isSpace,digitToInt)-import Data.List (nub,sort)-import Text.ParserCombinators.Parsec----------------------------------------------------------------- Language Definition-------------------------------------------------------------data LanguageDef st  -    = LanguageDef -    { commentStart   :: String-    , commentEnd     :: String-    , commentLine    :: String-    , nestedComments :: Bool                  -    , identStart     :: CharParser st Char-    , identLetter    :: CharParser st Char-    , opStart        :: CharParser st Char-    , opLetter       :: CharParser st Char-    , reservedNames  :: [String]-    , reservedOpNames:: [String]-    , caseSensitive  :: Bool-    }                           -           --------------------------------------------------------------- A first class module: TokenParser-------------------------------------------------------------data TokenParser st-    = TokenParser{ identifier       :: CharParser st String-                 , reserved         :: String -> CharParser st ()-                 , operator         :: CharParser st String-                 , reservedOp       :: String -> CharParser st ()-                        -                 , charLiteral      :: CharParser st Char-                 , stringLiteral    :: CharParser st String-                 , natural          :: CharParser st Integer-                 , integer          :: CharParser st Integer-                 , float            :: CharParser st Double-                 , naturalOrFloat   :: CharParser st (Either Integer Double)-                 , decimal          :: CharParser st Integer-                 , hexadecimal      :: CharParser st Integer-                 , octal            :: CharParser st Integer-            -                 , symbol           :: String -> CharParser st String-                 , lexeme           :: forall a. CharParser st a -> CharParser st a-                 , whiteSpace       :: CharParser st ()     -             -                 , parens           :: forall a. CharParser st a -> CharParser st a -                 , braces           :: forall a. CharParser st a -> CharParser st a-                 , angles           :: forall a. CharParser st a -> CharParser st a-                 , brackets         :: forall a. CharParser st a -> CharParser st a-                 -- "squares" is deprecated-                 , squares          :: forall a. CharParser st a -> CharParser st a --                 , semi             :: CharParser st String-                 , comma            :: CharParser st String-                 , colon            :: CharParser st String-                 , dot              :: CharParser st String-                 , semiSep          :: forall a . CharParser st a -> CharParser st [a]-                 , semiSep1         :: forall a . CharParser st a -> CharParser st [a]-                 , commaSep         :: forall a . CharParser st a -> CharParser st [a]-                 , commaSep1        :: forall a . CharParser st a -> CharParser st [a]                -                 }---------------------------------------------------------------- Given a LanguageDef, create a token parser.-------------------------------------------------------------makeTokenParser :: LanguageDef st -> TokenParser st-makeTokenParser languageDef-    = TokenParser{ identifier = identifier-                 , reserved = reserved-                 , operator = operator-                 , reservedOp = reservedOp-                        -                 , charLiteral = charLiteral-                 , stringLiteral = stringLiteral-                 , natural = natural-                 , integer = integer-                 , float = float-                 , naturalOrFloat = naturalOrFloat-                 , decimal = decimal-                 , hexadecimal = hexadecimal-                 , octal = octal-            -                 , symbol = symbol-                 , lexeme = lexeme-                 , whiteSpace = whiteSpace-             -                 , parens = parens-                 , braces = braces-                 , angles = angles-                 , brackets = brackets-                 , squares = brackets-                 , semi = semi-                 , comma = comma-                 , colon = colon-                 , dot = dot-                 , semiSep = semiSep-                 , semiSep1 = semiSep1-                 , commaSep = commaSep-                 , commaSep1 = commaSep1-                 }-    where-     -    ------------------------------------------------------------    -- Bracketing-    ------------------------------------------------------------    parens p        = between (symbol "(") (symbol ")") p-    braces p        = between (symbol "{") (symbol "}") p-    angles p        = between (symbol "<") (symbol ">") p-    brackets p      = between (symbol "[") (symbol "]") p--    semi            = symbol ";" -    comma           = symbol ","-    dot             = symbol "."-    colon           = symbol ":"--    commaSep p      = sepBy p comma-    semiSep p       = sepBy p semi--    commaSep1 p     = sepBy1 p comma-    semiSep1 p      = sepBy1 p semi---    ------------------------------------------------------------    -- Chars & Strings-    ------------------------------------------------------------    -- charLiteral :: CharParser st Char-    charLiteral     = lexeme (between (char '\'') -                                      (char '\'' <?> "end of character")-                                      characterChar )-                    <?> "character"--    characterChar   = charLetter <|> charEscape -                    <?> "literal character"--    charEscape      = do{ char '\\'; escapeCode }-    charLetter      = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))----    -- stringLiteral :: CharParser st String-    stringLiteral   = lexeme (-                      do{ str <- between (char '"')                   -                                         (char '"' <?> "end of string")-                                         (many stringChar) -                        ; return (foldr (maybe id (:)) "" str)-                        }-                      <?> "literal string")--    -- stringChar :: CharParser st (Maybe Char)-    stringChar      =   do{ c <- stringLetter; return (Just c) }-                    <|> stringEscape -                    <?> "string character"-                -    stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))--    stringEscape    = do{ char '\\'-                        ;     do{ escapeGap  ; return Nothing }-                          <|> do{ escapeEmpty; return Nothing }-                          <|> do{ esc <- escapeCode; return (Just esc) }-                        }-                        -    escapeEmpty     = char '&'-    escapeGap       = do{ many1 space-                        ; char '\\' <?> "end of string gap"-                        }-                        -                        -                        -    -- escape codes-    escapeCode      = charEsc <|> charNum <|> charAscii <|> charControl-                    <?> "escape code"--    -- charControl :: CharParser st Char-    charControl     = do{ char '^'-                        ; code <- upper-                        ; return (toEnum (fromEnum code - fromEnum 'A'))-                        }--    -- charNum :: CharParser st Char                    -    charNum         = do{ code <- decimal -                                  <|> do{ char 'o'; number 8 octDigit }-                                  <|> do{ char 'x'; number 16 hexDigit }-                        ; return (toEnum (fromInteger code))-                        }--    charEsc         = choice (map parseEsc escMap)-                    where-                      parseEsc (c,code)     = do{ char c; return code }-                      -    charAscii       = choice (map parseAscii asciiMap)-                    where-                      parseAscii (asc,code) = try (do{ string asc; return code })---    -- escape code tables-    escMap          = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")-    asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) --    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          = ['\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']---    ------------------------------------------------------------    -- Numbers-    ------------------------------------------------------------    -- naturalOrFloat :: CharParser st (Either Integer Double)-    naturalOrFloat  = lexeme (natFloat) <?> "number"--    float           = lexeme floating   <?> "float"-    integer         = lexeme int        <?> "integer"-    natural         = lexeme nat        <?> "natural"---    -- floats-    floating        = do{ n <- decimal -                        ; fractExponent n-                        }---    natFloat        = do{ char '0'-                        ; zeroNumFloat-                        }-                      <|> decimalFloat-                      -    zeroNumFloat    =  do{ n <- hexadecimal <|> octal-                         ; return (Left n)-                         }-                    <|> decimalFloat-                    <|> fractFloat 0-                    <|> return (Left 0)                  -                      -    decimalFloat    = do{ n <- decimal-                        ; option (Left n) -                                 (fractFloat n)-                        }--    fractFloat n    = do{ f <- fractExponent n-                        ; return (Right f)-                        }-                        -    fractExponent n = do{ fract <- fraction-                        ; expo  <- option 1.0 exponent'-                        ; return ((fromInteger n + fract)*expo)-                        }-                    <|>-                      do{ expo <- exponent'-                        ; return ((fromInteger n)*expo)-                        }--    fraction        = do{ char '.'-                        ; digits <- many1 digit <?> "fraction"-                        ; return (foldr op 0.0 digits)-                        }-                      <?> "fraction"-                    where-                      op d f    = (f + fromIntegral (digitToInt d))/10.0-                        -    exponent'       = do{ oneOf "eE"-                        ; f <- sign-                        ; e <- decimal <?> "exponent"-                        ; return (power (f e))-                        }-                      <?> "exponent"-                    where-                       power e  | e < 0      = 1.0/power(-e)-                                | otherwise  = fromInteger (10^e)---    -- integers and naturals-    int             = do{ f <- lexeme sign-                        ; n <- nat-                        ; return (f n)-                        }-                        -    -- sign            :: CharParser st (Integer -> Integer)-    sign            =   (char '-' >> return negate) -                    <|> (char '+' >> return id)     -                    <|> return id--    nat             = zeroNumber <|> decimal-        -    zeroNumber      = do{ char '0'-                        ; hexadecimal <|> octal <|> decimal <|> return 0-                        }-                      <?> ""       --    decimal         = number 10 digit        -    hexadecimal     = do{ oneOf "xX"; number 16 hexDigit }-    octal           = do{ oneOf "oO"; number 8 octDigit  }--    -- number :: Integer -> CharParser st Char -> CharParser st Integer-    number base baseDigit-        = do{ digits <- many1 baseDigit-            ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits-            ; seq n (return n)-            }          --    ------------------------------------------------------------    -- Operators & reserved ops-    ------------------------------------------------------------    reservedOp name =   -        lexeme $ try $-        do{ string name-          ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)-          }--    operator =-        lexeme $ try $-        do{ name <- oper-          ; if (isReservedOp name)-             then unexpected ("reserved operator " ++ show name)-             else return name-          }-          -    oper =-        do{ c <- (opStart languageDef)-          ; cs <- many (opLetter languageDef)-          ; return (c:cs)-          }-        <?> "operator"-        -    isReservedOp name =-        isReserved (sort (reservedOpNames languageDef)) name          -        -        -    ------------------------------------------------------------    -- Identifiers & Reserved words-    ------------------------------------------------------------    reserved name =-        lexeme $ try $-        do{ caseString name-          ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)-          }--    caseString name-        | caseSensitive languageDef  = string name-        | otherwise               = do{ walk name; return name }-        where-          walk []     = return ()-          walk (c:cs) = do{ caseChar c <?> msg; walk cs }-          -          caseChar c  | isAlpha c  = char (toLower c) <|> char (toUpper c)-                      | otherwise  = char c-          -          msg         = show name-          --    identifier =-        lexeme $ try $-        do{ name <- ident-          ; if (isReservedName name)-             then unexpected ("reserved word " ++ show name)-             else return name-          }-        -        -    ident           -        = do{ c <- identStart languageDef-            ; cs <- many (identLetter languageDef)-            ; return (c:cs)-            }-        <?> "identifier"--    isReservedName name-        = isReserved theReservedNames caseName-        where-          caseName      | caseSensitive languageDef  = name-                        | otherwise               = map toLower name--        -    isReserved names name    -        = scan names-        where-          scan []       = False-          scan (r:rs)   = case (compare r name) of-                            LT  -> scan rs-                            EQ  -> True-                            GT  -> False--    theReservedNames-        | caseSensitive languageDef  = sortedNames-        | otherwise               = map (map toLower) sortedNames-        where-          sortedNames   = sort (reservedNames languageDef)-                                 ---    ------------------------------------------------------------    -- White space & symbols-    ------------------------------------------------------------    symbol name-        = lexeme (string name)--    lexeme p       -        = do{ x <- p; whiteSpace; return x  }-      -      -    --whiteSpace    -    whiteSpace -        | noLine && noMulti  = skipMany (simpleSpace <?> "")-        | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")-        | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")-        | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")-        where-          noLine  = null (commentLine languageDef)-          noMulti = null (commentStart languageDef)   -          -          -    simpleSpace =-        skipMany1 (satisfy isSpace)    -        -    oneLineComment =-        do{ try (string (commentLine languageDef))-          ; skipMany (satisfy (/= '\n'))-          ; return ()-          }--    multiLineComment =-        do { try (string (commentStart languageDef))-           ; inComment-           }--    inComment -        | nestedComments languageDef  = inCommentMulti-        | otherwise                = inCommentSingle-        -    inCommentMulti -        =   do{ try (string (commentEnd languageDef)) ; return () }-        <|> do{ multiLineComment                     ; inCommentMulti }-        <|> do{ skipMany1 (noneOf startEnd)          ; inCommentMulti }-        <|> do{ oneOf startEnd                       ; inCommentMulti }-        <?> "end of comment"  -        where-          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)--    inCommentSingle-        =   do{ try (string (commentEnd languageDef)); return () }-        <|> do{ skipMany1 (noneOf startEnd)         ; inCommentSingle }-        <|> do{ oneOf startEnd                      ; inCommentSingle }-        <?> "end of comment"-        where-          startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)+    ( LanguageDef,+      GenLanguageDef(..),+      TokenParser,+      GenTokenParser(..),+      makeTokenParser+    ) where +import Text.Parsec.Token
parsec.cabal view
@@ -1,35 +1,48 @@-cabal-version: >= 1.2 name:		parsec-version:	2.1.0.1+version:	3.0.0+cabal-version: >= 1.2 license:	BSD3 license-file:	LICENSE-author:		Daan Leijen <daan@cs.uu.nl>-maintainer:	Daan Leijen <daan@cs.uu.nl>+author:		Daan Leijen <daan@cs.uu.nl>, Paolo Martini <paolo@nemail.it>+maintainer:	Derek Elkins <derek.a.elkins@gmail.com> homepage:	http://www.cs.uu.nl/~daan/parsec.html category:	Parsing synopsis:	Monadic parser combinators+build-type: Simple description:-    Parsec is designed from scratch as an industrial-strength parser-    library.  It is simple, safe, well documented (on the package-    homepage), has extensive libraries and good error messages,-    and is also fast.-build-type:     Simple-library {-  exposed-modules:-    Text.ParserCombinators.Parsec.Error,-    Text.ParserCombinators.Parsec.Char,-    Text.ParserCombinators.Parsec.Combinator,-    Text.ParserCombinators.Parsec.Expr,-    Text.ParserCombinators.Parsec.Perm,-    Text.ParserCombinators.Parsec.Pos,-    Text.ParserCombinators.Parsec.Prim,-    Text.ParserCombinators.Parsec-  build-depends:	base-  extensions:	ExistentialQuantification-  if !impl(nhc98) {-    extensions:	PolymorphicComponents+	Parsec is designed from scratch as an industrial-strength parser+	library.  It is simple, safe, well documented (on the package+	homepage), has extensive libraries and good error messages,+	and is also fast.  It is defined as a monad transformer that can be+	stacked on arbitrary monads, and it is also parametric in the+	input stream type.++library         exposed-modules:-      Text.ParserCombinators.Parsec.Language,-      Text.ParserCombinators.Parsec.Token-  }-}+        Text.Parsec,+        Text.Parsec.String,+        Text.Parsec.ByteString,+        Text.Parsec.ByteString.Lazy,+        Text.Parsec.Pos,+        Text.Parsec.Error,+        Text.Parsec.Prim,+        Text.Parsec.Char,+        Text.Parsec.Combinator,+        Text.Parsec.Token,+        Text.Parsec.Expr,+        Text.Parsec.Language,+        Text.Parsec.Perm,+        Text.ParserCombinators.Parsec,+        Text.ParserCombinators.Parsec.Char,+        Text.ParserCombinators.Parsec.Combinator,+        Text.ParserCombinators.Parsec.Error,+        Text.ParserCombinators.Parsec.Expr,+        Text.ParserCombinators.Parsec.Language,+        Text.ParserCombinators.Parsec.Perm,+        Text.ParserCombinators.Parsec.Pos,+        Text.ParserCombinators.Parsec.Prim,+        Text.ParserCombinators.Parsec.Token+    build-depends:	base, mtl, bytestring+    extensions:	ExistentialQuantification, PolymorphicComponents, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts+    ghc-options:	-O2+    ghc-prof-options:	-auto-all