diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright 1999-2000, Daan Leijen. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +This software is provided by the copyright holders "as is" and any express or +implied warranties, including, but not limited to, the implied warranties of +merchantability and fitness for a particular purpose are disclaimed. In no +event shall the copyright holders be liable for any direct, indirect, +incidental, special, exemplary, or consequential damages (including, but not +limited to, procurement of substitute goods or services; loss of use, data, +or profits; or business interruption) however caused and on any theory of +liability, whether in contract, strict liability, or tort (including +negligence or otherwise) arising in any way out of the use of this software, +even if advised of the possibility of such damage. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/Text/ParserCombinators/Parsec.hs b/Text/ParserCombinators/Parsec.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Parsec, the Fast Monadic Parser combinator library, see +-- . +-- +-- Inspired by: +-- +-- * Graham Hutton and Erik Meijer: +-- Monadic Parser Combinators. +-- Technical report NOTTCS-TR-96-4. +-- Department of Computer Science, University of Nottingham, 1996. +-- +-- +-- * 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. +-- +----------------------------------------------------------------------------- + +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 + + ) where + +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 + diff --git a/Text/ParserCombinators/Parsec/Char.hs b/Text/ParserCombinators/Parsec/Char.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Char.hs @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Char +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Commonly used character parsers. +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Char + ( 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) + +string :: String -> CharParser st String +string s = tokens show updatePosString s diff --git a/Text/ParserCombinators/Parsec/Combinator.hs b/Text/ParserCombinators/Parsec/Combinator.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Combinator.hs @@ -0,0 +1,152 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Combinator +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Commonly used generic combinators +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Combinator + ( choice + , count + , between + , option, 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 + +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) } + + +lookAhead :: GenParser tok st a -> GenParser tok st a +lookAhead p = do{ state <- getParserState + ; x <- p + ; setParserState state + ; return x + } diff --git a/Text/ParserCombinators/Parsec/Error.hs b/Text/ParserCombinators/Parsec/Error.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Error.hs @@ -0,0 +1,164 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Error +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Parse errors +-- +----------------------------------------------------------------------------- + +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 + + +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 + +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) + diff --git a/Text/ParserCombinators/Parsec/Expr.hs b/Text/ParserCombinators/Parsec/Expr.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Expr.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Expr +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A helper module to parse \"expressions\". +-- Builds a parser given a table of operators and associativities. +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Expr + ( Assoc(..), Operator(..), OperatorTable + , buildExpressionParser + ) where + +import Text.ParserCombinators.Parsec.Prim +import Text.ParserCombinators.Parsec.Combinator + + +----------------------------------------------------------- +-- 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)) + +type OperatorTable t st a = [[Operator t 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" + } + + + 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) + diff --git a/Text/ParserCombinators/Parsec/Language.hs b/Text/ParserCombinators/Parsec/Language.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Language.hs @@ -0,0 +1,124 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Language +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- 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"). +-- +----------------------------------------------------------------------------- + +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 + } + + diff --git a/Text/ParserCombinators/Parsec/Perm.hs b/Text/ParserCombinators/Parsec/Perm.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Perm.hs @@ -0,0 +1,122 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Perm +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- 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. +-- +----------------------------------------------------------------------------- + +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' + + +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 diff --git a/Text/ParserCombinators/Parsec/Pos.hs b/Text/ParserCombinators/Parsec/Pos.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Pos.hs @@ -0,0 +1,99 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Pos +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Textual source positions. +-- +----------------------------------------------------------------------------- + +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)) + +----------------------------------------------------------- +-- 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 ++ + ")" diff --git a/Text/ParserCombinators/Parsec/Prim.hs b/Text/ParserCombinators/Parsec/Prim.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Prim.hs @@ -0,0 +1,456 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Prim +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- The primitive parser combinators. +-- +----------------------------------------------------------------------------- + +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)))) + + +----------------------------------------------------------- +-- MonadPlus: alternative (mplus) and mzero +----------------------------------------------------------- +instance MonadPlus (GenParser tok st) where + mzero = parsecZero + mplus p1 p2 = parsecPlus p1 p2 + + +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 +-} + + +----------------------------------------------------------- +-- 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) + + diff --git a/Text/ParserCombinators/Parsec/Token.hs b/Text/ParserCombinators/Parsec/Token.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Token.hs @@ -0,0 +1,473 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Token +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : non-portable (uses existentially quantified data constructors) +-- +-- A helper module to parse lexical elements (tokens). +-- +----------------------------------------------------------------------------- + +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) + diff --git a/parsec.cabal b/parsec.cabal new file mode 100644 --- /dev/null +++ b/parsec.cabal @@ -0,0 +1,27 @@ +name: parsec +version: 2.0 +license: BSD3 +license-file: LICENSE +author: Daan Leijen +maintainer: Daan Leijen +homepage: http://www.cs.uu.nl/~daan/parsec.html +category: Parsing +synopsis: Monadic parser combinators +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. +exposed-modules: + Text.ParserCombinators.Parsec.Error, + Text.ParserCombinators.Parsec.Char, + Text.ParserCombinators.Parsec.Combinator, + Text.ParserCombinators.Parsec.Expr, + Text.ParserCombinators.Parsec.Language, + Text.ParserCombinators.Parsec.Perm, + Text.ParserCombinators.Parsec.Pos, + Text.ParserCombinators.Parsec.Prim, + Text.ParserCombinators.Parsec.Token, + Text.ParserCombinators.Parsec +build-depends: base +extensions: ExistentialQuantification, PolymorphicComponents