Commit 792c0b58 authored by panne's avatar panne
Browse files

[project @ 2002-05-31 12:22:33 by panne]

Moved Parsec to its new home
parent c7b9b8a5
......@@ -12,6 +12,9 @@ sources:
which is (c) Manuel M. T. Chakravarty and freely redistributable
(but see the full license for restrictions).
* Code from the Parsec library which is (c) Daan Leijen, and
distributable under a BSD-style license (see below).
The full text of these licenses is reproduced below.
-----------------------------------------------------------------------------
......@@ -80,3 +83,28 @@ the following license:
be a definition of the Haskell 98 Foreign Function Interface.
-----------------------------------------------------------------------------
Code derived from Daan Leijen's Parsec is distributed under the following
license:
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.
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.28 2002/05/27 14:30:49 simonmar Exp $
# $Id: Makefile,v 1.29 2002/05/31 12:22:33 panne Exp $
TOP=..
include $(TOP)/mk/boilerplate.mk
......@@ -35,6 +35,7 @@ ALL_DIRS = \
Text/Html \
Text/PrettyPrint \
Text/ParserCombinators \
Text/ParserCombinators/Parsec \
Text/Regex \
Text/Show \
Text/Read
......
-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.Parsec
-- Copyright : (c) Daan Leijen 1999-2001
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : daan@cs.uu.nl
-- Stability : provisional
-- Portability : portable
--
-- Parsec, the Fast Monadic Parser combinator library.
-- <http://www.cs.uu.nl/people/daan/parsec.html>
--
-- This helper module exports elements from the basic libraries.
-- 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/Department/Staff/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
--
-----------------------------------------------------------------------------
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
-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.Parsec.Char
-- Copyright : (c) Daan Leijen 1999-2001
-- License : BSD-style (see the file libraries/base/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 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 cs = satisfy (\c -> elem c cs)
noneOf cs = satisfy (\c -> not (elem c cs))
spaces = skipMany space <?> "white space"
space = satisfy (isSpace) <?> "space"
newline = char '\n' <?> "new-line"
tab = char '\t' <?> "tab"
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 c = satisfy (==c) <?> show [c]
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
\ No newline at end of file
-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.Parsec.Combinator
-- Copyright : (c) Daan Leijen 1999-2001
-- License : BSD-style (see the file libraries/base/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 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
}
-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.Parsec.Error
-- Copyright : (c) Daan Leijen 1999-2001
-- License : BSD-style (see the file libraries/base/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 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 msg1 msg2
= compare (messageToEnum msg1) (messageToEnum msg2)
messageString msg
= case msg of SysUnExpect s -> s
UnExpect s -> s
Expect s -> s
Message s -> s
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 pos
= ParseError pos []
newErrorMessage msg pos
= ParseError pos [msg]
addErrorMessage msg (ParseError pos msgs)
= ParseError pos (msg:msgs)
setErrorPos pos (ParseError _ msgs)
= ParseError pos msgs
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 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)
-----------------------------------------------------------------------------
-- |
-- Module : Text.ParserCombinators.Parsec.Expr
-- Copyright : (c) Daan Leijen 1999-2001
-- License : BSD-style (see the file libraries/base/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)