diff --git a/LICENSE b/LICENSE index 19f2d1102..2c7196677 100644 --- a/LICENSE +++ b/LICENSE @@ -12,9 +12,6 @@ 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. All of the licenses are BSD-style or compatible. @@ -84,30 +81,3 @@ 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. - ------------------------------------------------------------------------------ diff --git a/Makefile b/Makefile index 7ed06cbcf..ebc5f2e22 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.46 2003/07/24 13:53:20 simonmar Exp $ +# $Id: Makefile,v 1.47 2003/07/31 17:45:22 ross Exp $ TOP=.. include $(TOP)/mk/boilerplate.mk @@ -33,7 +33,6 @@ ALL_DIRS = \ Text/Html \ Text/PrettyPrint \ Text/ParserCombinators \ - Text/ParserCombinators/Parsec \ Text/Regex \ Text/Show \ Text/Read diff --git a/Makefile.nhc98 b/Makefile.nhc98 index 74ae9c333..9668dce93 100644 --- a/Makefile.nhc98 +++ b/Makefile.nhc98 @@ -23,14 +23,6 @@ SRCS = \ Foreign/Marshal/Utils.hs Foreign/Marshal/Error.hs \ Foreign/Marshal/Pool.hs Foreign/Marshal.hs \ Foreign/C/String.hs Foreign/C/Error.hs Foreign/C.hs Foreign.hs \ - Text/ParserCombinators/Parsec/Char.hs \ - Text/ParserCombinators/Parsec/Combinator.hs \ - Text/ParserCombinators/Parsec/Error.hs \ - Text/ParserCombinators/Parsec/Expr.hs \ - Text/ParserCombinators/Parsec/Perm.hs \ - Text/ParserCombinators/Parsec/Pos.hs \ - Text/ParserCombinators/Parsec/Prim.hs \ - Text/ParserCombinators/Parsec.hs \ Text/PrettyPrint/HughesPJ.hs Text/PrettyPrint.hs \ Text/Html/BlockTable.hs Text/Html.hs \ Text/Read.hs Text/Show.hs Text/Show/Functions.hs @@ -41,8 +33,6 @@ SRCS = \ # System/CPUTime.hsc System/Time.hsc # System/Mem.hs System/Mem/StableName.hs System/Mem/Weak.hs # System/Posix/Types.hs System/Posix/Signals.hsc -# Text/ParserCombinators/Parsec/Token.hs \ -# Text/ParserCombinators/Parsec/Language.hs \ # Text/ParserCombinators/ReadP.hs Text/ParserCombinators/ReadPrec.hs # Text/Read/Lex.hs # Text/Regex/* Text/Regex.hs @@ -84,26 +74,6 @@ $(OBJDIR)/Foreign/Marshal/Utils.$O: $(OBJDIR)/Data/Maybe.$O \ $(OBJDIR)/Foreign/Marshal/Error.$O: $(OBJDIR)/Foreign/Ptr.$O $(OBJDIR)/Foreign/C/String.$O: $(OBJDIR)/Data/Word.$O $(OBJDIR)/Foreign/Ptr.$O \ $(OBJDIR)/Foreign/Marshal/Array.$O $(OBJDIR)/Foreign/C/Types.$O -$(OBJDIR)/Text/ParserCombinators/Parsec/Char.$O: \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Pos.$O \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Prim.$O -$(OBJDIR)/Text/ParserCombinators/Parsec/Combinator.$O: \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Prim.$O -$(OBJDIR)/Text/ParserCombinators/Parsec/Error.$O: \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Pos.$O -$(OBJDIR)/Text/ParserCombinators/Parsec/Expr.$O: \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Prim.$O \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Combinator.$O -$(OBJDIR)/Text/ParserCombinators/Parsec/Language.$O: \ - $(OBJDIR)/Text/ParserCombinators/Parsec.$O \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Token.$O -$(OBJDIR)/Text/ParserCombinators/Parsec/Perm.$O: \ - $(OBJDIR)/Text/ParserCombinators/Parsec.$O -$(OBJDIR)/Text/ParserCombinators/Parsec/Prim.$O: \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Pos.$O \ - $(OBJDIR)/Text/ParserCombinators/Parsec/Error.$O -$(OBJDIR)/Text/ParserCombinators/Parsec/Token.$O: \ - $(OBJDIR)/Text/ParserCombinators/Parsec.$O # C-files dependencies. Data/FiniteMap.$C: Data/Maybe.$C @@ -129,24 +99,4 @@ Foreign/Marshal/Utils.$C: Data/Maybe.$C Foreign/Ptr.$C Foreign/Storable.$C \ Foreign/Marshal/Error.$C: Foreign/Ptr.$C Foreign/C/String.$C: Data/Word.$C Foreign/Ptr.$C Foreign/C/Types.$C \ Foreign/Marshal/Array.$C -Text/ParserCombinators/Parsec/Char.$C: \ - Text/ParserCombinators/Parsec/Pos.$C \ - Text/ParserCombinators/Parsec/Prim.$C -Text/ParserCombinators/Parsec/Combinator.$C: \ - Text/ParserCombinators/Parsec/Prim.$C -Text/ParserCombinators/Parsec/Error.$C: \ - Text/ParserCombinators/Parsec/Pos.$C -Text/ParserCombinators/Parsec/Expr.$C: \ - Text/ParserCombinators/Parsec/Prim.$C \ - Text/ParserCombinators/Parsec/Combinator.$C -Text/ParserCombinators/Parsec/Language.$C: \ - Text/ParserCombinators/Parsec.$C \ - Text/ParserCombinators/Parsec/Token.$C -Text/ParserCombinators/Parsec/Perm.$C: \ - Text/ParserCombinators/Parsec.$C -Text/ParserCombinators/Parsec/Prim.$C: \ - Text/ParserCombinators/Parsec/Pos.$C \ - Text/ParserCombinators/Parsec/Error.$C -Text/ParserCombinators/Parsec/Token.$C: \ - Text/ParserCombinators/Parsec.$C diff --git a/Text/ParserCombinators/Parsec.hs b/Text/ParserCombinators/Parsec.hs deleted file mode 100644 index a9ef347ba..000000000 --- a/Text/ParserCombinators/Parsec.hs +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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, 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 deleted file mode 100644 index 05f3ad09e..000000000 --- a/Text/ParserCombinators/Parsec/Char.hs +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 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 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 diff --git a/Text/ParserCombinators/Parsec/Combinator.hs b/Text/ParserCombinators/Parsec/Combinator.hs deleted file mode 100644 index e46e25b59..000000000 --- a/Text/ParserCombinators/Parsec/Combinator.hs +++ /dev/null @@ -1,151 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - } diff --git a/Text/ParserCombinators/Parsec/Error.hs b/Text/ParserCombinators/Parsec/Error.hs deleted file mode 100644 index abb3c690c..000000000 --- a/Text/ParserCombinators/Parsec/Error.hs +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 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 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 deleted file mode 100644 index 8f5d3152d..000000000 --- a/Text/ParserCombinators/Parsec/Expr.hs +++ /dev/null @@ -1,123 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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) - = (rassoc,lassoc,nassoc,prefix,op:postfix) - diff --git a/Text/ParserCombinators/Parsec/Language.hs b/Text/ParserCombinators/Parsec/Language.hs deleted file mode 100644 index 838a348d3..000000000 --- a/Text/ParserCombinators/Parsec/Language.hs +++ /dev/null @@ -1,118 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Language --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/base/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= emptyDef - { commentStart = "{-" - , commentEnd = "-}" - , commentLine = "--" - , nestedComments = True - , identStart = letter - , identLetter = alphaNum <|> oneOf "_'" - , opStart = opLetter haskellStyle - , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" - , reservedOpNames= [] - , reservedNames = [] - , caseSensitive = True - } - -javaStyle = emptyDef - { commentStart = "/*" - , commentEnd = "*/" - , commentLine = "//" - , nestedComments = True - , identStart = letter - , identLetter = alphaNum <|> oneOf "_'" - , reservedNames = [] - , reservedOpNames= [] - , caseSensitive = False - } - ------------------------------------------------------------ --- minimal language definition ------------------------------------------------------------ -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 = haskell98Def - { identLetter = identLetter haskell98Def <|> char '#' - , reservedNames = reservedNames haskell98Def ++ - ["foreign","import","export","primitive" - ,"_ccall_","_casm_" - ,"forall" - ] - } - -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 = 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 deleted file mode 100644 index cbdbfe0b8..000000000 --- a/Text/ParserCombinators/Parsec/Perm.hs +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Perm --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/base/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 -(<$$>) f p = newperm f <||> p - -(<|?>) perm (x,p) = addopt perm x p -(<$?>) 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 deleted file mode 100644 index 31391ad05..000000000 --- a/Text/ParserCombinators/Parsec/Pos.hs +++ /dev/null @@ -1,86 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Pos --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/base/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 - = newPos sourceName 1 1 - -sourceName (SourcePos name line column) = name -sourceLine (SourcePos name line column) = line -sourceColumn (SourcePos name line column) = column - -incSourceLine (SourcePos name line column) n = SourcePos name (line+n) column -incSourceColumn (SourcePos name line column) n = SourcePos name line (column+n) - -setSourceName (SourcePos name line column) n = SourcePos n line column -setSourceLine (SourcePos name line column) n = SourcePos name n column -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 - '\r' -> 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 deleted file mode 100644 index 48897170a..000000000 --- a/Text/ParserCombinators/Parsec/Prim.hs +++ /dev/null @@ -1,430 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Prim --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/base/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 - , try, label, labels, unexpected, pzero - - -- primitive because of space behaviour - , many, skipMany - - -- user state manipulation - , getState, setState, updateState - - -- state manipulation - , getPosition, setPosition - , getInput, setInput - , 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 - = 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) - ) - - -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 seq newstate $ - 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 deleted file mode 100644 index 529eac9f4..000000000 --- a/Text/ParserCombinators/Parsec/Token.hs +++ /dev/null @@ -1,473 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Text.ParserCombinators.Parsec.Token --- Copyright : (c) Daan Leijen 1999-2001 --- License : BSD-style (see the file libraries/base/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/Text/ParserCombinators/Parsec/examples/Henk/HenkAS.hs b/Text/ParserCombinators/Parsec/examples/Henk/HenkAS.hs deleted file mode 100644 index 9c62dd04a..000000000 --- a/Text/ParserCombinators/Parsec/examples/Henk/HenkAS.hs +++ /dev/null @@ -1,151 +0,0 @@ ----------------------------------------------------------------- --- the Henk Abstract Syntax --- Copyright 2000, Jan-Willem Roorda and Daan Leijen ----------------------------------------------------------------- -module HenkAS where - -import Pretty - ----------------------------------------------------------------- --- Abstract Syntax ----------------------------------------------------------------- -data Program = Program [TypeDecl] [ValueDecl] - -data TypeDecl = Data Var [Var] - -data ValueDecl = Let Bind - | LetRec [Bind] - -data Bind = Bind Var Expr - -data Expr = Var Var - | Lit Lit - | Box - | Star - | Unknown - - | App Expr Expr - | Case Expr [Alt] [Expr] - | In ValueDecl Expr - | Pi Var Expr - | Lam Var Expr - -data Alt = Alt Pat Expr - -data Pat = PatVar Var - | PatLit Lit - -data Var = TVar Identifier Expr - -data Lit = LitInt Integer - -type Identifier = String - -anonymous = "_" -isAnonymous s = (null s || (head s == head anonymous)) - - ----------------------------------------------------------------- --- pretty print abstract syntax ----------------------------------------------------------------- -instance Show Program where - showsPrec d program = shows (pprogram program) - -vsep ds - = vcat (map ($$ text "") ds) - - --- program -pprogram (Program tdecls vdecls) - = vsep ((map ptdecl tdecls) ++ (map pvdecl vdecls)) - -ptdecl (Data v vs) - = (text "data" <+> pbindvar v) - $$ indent (text "=" <+> braced (map ptvar vs)) - - -pvdecl vdecl - = case vdecl of - Let bind -> text "let" <+> pbind bind - LetRec binds -> text "letrec" $$ indent (braced (map pbind binds)) - -pbind (Bind v e) - = pbindvar v $$ indent (text "=" <+> pexpr e) - --- expressions (are parenthesis correct ?) -parensExpr e - = case e of - In _ _ -> parens (pexpr e) - Pi _ _ -> parens (pexpr e) - Lam _ _ -> parens (pexpr e) - Case _ _ _ -> parens (pexpr e) - App _ _ -> parens (pexpr e) - Var (TVar i t) -> case t of - Unknown -> pexpr e - other -> parens (pexpr e) - other -> pexpr e - -pexpr e - = case e of - Var v -> pboundvar v - Lit l -> plit l - Box -> text "[]" - Star -> text "*" - Unknown -> text "?" - - App e1 e2 -> pexpr e1 <+> parensExpr e2 - Case e as ts-> sep $ [text "case" <+> parensExpr e <+> text "of" - ,nest 3 (braced (map palt as)) - ] ++ - (if (null as) - then [] - else [text "at" - ,nest 3 (braced (map pexpr ts)) - ]) - - In v e -> sep[ pvdecl v, text "in" <+> pexpr e] - Pi v e -> case v of - TVar i t | isAnonymous i -> parensExpr t <+> text "->" <+> pexpr e - TVar i Star -> sep[ text "\\/" <> text i <> text ".", pexpr e] - other -> sep[ text "|~|" <> pbindvar v <> text ".", pexpr e] - Lam v e -> case v of - TVar i Star -> sep[ text "/\\" <> text i <> text ".", pexpr e] - other -> sep[ text "\\" <> pbindvar v <> text ".", pexpr e] - - --- atomic stuff -palt (Alt p e) - = ppat p <+> text "=>" <+> pexpr e - -ppat p - = case p of PatVar v -> pboundvar v - PatLit l -> plit l - - -pboundvar v@(TVar i e) - = case e of Unknown -> text i - other -> ptvar v - -pbindvar v@(TVar i e) - = case e of Star -> text i - other -> ptvar v - -ptvar (TVar i e) - = text i <> colon <+> pexpr e - - -plit l - = case l of LitInt i -> integer i - -braced [] - = empty - -braced ds - = let prefix = map text $ ["{"] ++ repeat ";" - in cat ((zipWith (<+>) prefix ds) ++ [text "}"]) - -indent - = nest 4 - - - \ No newline at end of file diff --git a/Text/ParserCombinators/Parsec/examples/Henk/HenkParser.hs b/Text/ParserCombinators/Parsec/examples/Henk/HenkParser.hs deleted file mode 100644 index 290cda746..000000000 --- a/Text/ParserCombinators/Parsec/examples/Henk/HenkParser.hs +++ /dev/null @@ -1,277 +0,0 @@ ----------------------------------------------------------------- --- the Henk Parser --- Copyright 2000, Jan-Willem Roorda and Daan Leijen ----------------------------------------------------------------- -module HenkParser where - -import Text.ParserCombinators.Parsec. -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Expr -import Text.ParserCombinators.Parsec.Language - -import HenkAS - ----------------------------------------------------------------- --- the Henk Parser --- --- anonymous variables are any identifiers starting with "_" --- --- unknown types (those that need to be inferred) can explicitly --- be given using "?" --- --- instead of grammar: "var : aexpr" as in the henk paper, --- we use "var : expr" instead. This means that variable --- sequences as in \, |~|, \/ and /\ expressions need to --- be comma seperated. Pattern variables are also comma --- seperated. The case arrow (->) now needs to be (=>) in --- order to distinguish the end of the pattern from function --- arrows. ----------------------------------------------------------------- -program - = do{ whiteSpace - ; ts <- semiSep tdecl - ; vs <- semiSep vdecl - ; eof - ; return $ Program ts vs - } - ----------------------------------------------------------------- --- Type declarations ----------------------------------------------------------------- -tdecl - = do{ reserved "data" - ; t <- bindVar - ; symbol "=" - ; ts <- braces (semiSep1 tvar) - ; return $ Data t ts - } - ----------------------------------------------------------------- --- Value declarations ----------------------------------------------------------------- -vdecl :: Parser ValueDecl -vdecl - = do{ reserved "let" - ; b <- bind - ; return $ Let b - } - <|> - do{ reserved "letrec" - ; bs <- braces (semiSep1 bind) - ; return $ LetRec bs - } - - -bind - = do{ t <- tvar - ; symbol "=" - ; e <- expr - ; return $ Bind t e - } - ----------------------------------------------------------------- --- Expressions ----------------------------------------------------------------- -expr :: Parser Expr -expr - = choice - [ letExpr - , forallExpr -- forall before lambda! \/ vs. \ - , lambdaExpr - , piExpr - , caseExpr - - , functionExpr - , bigLamdaExpr - ] - "expression" - -letExpr - = do{ vd <- vdecl - ; reserved "in" - ; e <- expr - ; return (In vd e) - } - -lambdaExpr - = do{ symbol "\\" - ; ts <- commaSep1 bindVar - ; symbol "." - ; e <- expr - ; return $ (foldr Lam e ts) - } - -piExpr - = do{ symbol "|~|" - ; ts <- commaSep1 bindVar - ; symbol "." - ; e <- expr - ; return (foldr Pi e ts) - } - ----------------------------------------------------------------- --- Case expressions ----------------------------------------------------------------- -caseExpr - = do{ reserved "case" - ; e <- expr - ; reserved "of" - ; as <- braces (semiSep1 alt) - ; es <- option [] (do{ reserved "at" - ; braces (semiSep expr) - }) - ; return (Case e as es) - } - -alt - = do{ pat <- pattern - ; symbol "=>" - ; e <- expr - ; return (pat e) - } - -pattern - = do{ p <- atomPattern - ; vs <- commaSep boundVar - ; return (\e -> Alt p (foldr Lam e vs)) - } - -atomPattern - = do{ v <- boundVar - ; return (PatVar v) - } - <|> do{ l <- literal - ; return (PatLit l) - } - "pattern" - - ----------------------------------------------------------------- --- Syntactic sugar: ->, \/, /\ ----------------------------------------------------------------- -functionExpr - = chainr1 appExpr arrow - where - arrow = do{ symbol "->" - ; return ((\x y -> - Pi (TVar anonymous x) y)) - } - "" - -bigLamdaExpr - = do{ symbol "/\\" - ; ts <- commaSep1 bindVar - ; symbol "." - ; e <- expr - ; return (foldr Lam e ts) - } - -forallExpr - = do{ try (symbol "\\/") -- use "try" to try "\" (lambda) too. - ; ts <- commaSep1 bindVar - ; symbol "." - ; e <- expr - ; return (foldr Pi e ts) - } - ----------------------------------------------------------------- --- Simple expressions ----------------------------------------------------------------- -appExpr - = do{ es <- many1 atomExpr - ; return (foldl1 App es) - } - -atomExpr - = parens expr - <|> do{ v <- boundVar; return (Var v) } - <|> do{ l <- literal; return (Lit l)} - <|> do{ symbol "*"; return Star } - <|> do{ symbol "[]"; return Box } - <|> do{ symbol "?"; return Unknown } - "simple expression" - - ----------------------------------------------------------------- --- Variables & Literals ----------------------------------------------------------------- -variable - = identifier - -anonymousVar - = lexeme $ - do{ c <- char '_' - ; cs <- many (identLetter henkDef) - ; return (c:cs) - } - -bindVar - = do{ i <- variable <|> anonymousVar - ; do{ e <- varType - ; return (TVar i e) - } - <|> return (TVar i Star) - } - "variable" - -boundVar - = do{ i <- variable - ; do{ e <- varType - ; return (TVar i e) - } - <|> return (TVar i Unknown) - } - "variable" - - -tvar - = do{ v <- variable - ; t <- varType - ; return (TVar v t) - } - "typed variable" - -varType - = do{ symbol ":" - ; expr - } - "variable type" - -literal - = do{ i <- natural - ; return (LitInt i) - } - "literal" - - ----------------------------------------------------------------- --- Tokens ----------------------------------------------------------------- -henk = P.makeTokenParser henkDef - -lexeme = P.lexeme henk -parens = P.parens henk -braces = P.braces henk -semiSep = P.semiSep henk -semiSep1 = P.semiSep1 henk -commaSep = P.commaSep henk -commaSep1 = P.commaSep1 henk -whiteSpace = P.whiteSpace henk -symbol = P.symbol henk -identifier = P.identifier henk -reserved = P.reserved henk -natural = P.natural henk - - -henkDef - = haskellStyle - { identStart = letter - , identLetter = alphaNum <|> oneOf "_'" - , opStart = opLetter henkDef - , opLetter = oneOf ":=\\->/|~.*[]" - , reservedOpNames = ["::","=","\\","->","=>","/\\","\\/" - ,"|~|",".",":","*","[]"] - , reservedNames = [ "case", "data", "letrec", "type" - , "import", "in", "let", "of", "at" - ] - } diff --git a/Text/ParserCombinators/Parsec/examples/Henk/Main.hs b/Text/ParserCombinators/Parsec/examples/Henk/Main.hs deleted file mode 100644 index fed9adb5a..000000000 --- a/Text/ParserCombinators/Parsec/examples/Henk/Main.hs +++ /dev/null @@ -1,37 +0,0 @@ ----------------------------------------------------------------- --- Henk --- Copyright 2000, Jan-Willem Roorda ----------------------------------------------------------------- -module Main where - -import Text.ParserCombinators.Parsec - -import HenkAS -import HenkParser - - -welcome = "__ __ ______ __ __ ____ __________________________________________\n"++ - "|| || || || ||\\ || ||// Henk 2000: Based on Pure Type Systems \n"++ - "||___|| ||_| ||\\\\ || ||\\\\ \n"++ - "||---|| ||-|__ || \\\\|| WWW http://www.students.cs.uu.nl/~jwroorda\n"++ - "|| || ||__|| Report bugs to: jwroorda@math.uu.nl \n"++ - "|| || Version: Jan 2000 __________________________________________\n\n" - - - -test fname - = do{ putStr welcome - ; result <- parseFromFile program (root ++ fname ++ ".h") - ; case result of - Left err -> do{ putStr "parse error at: " - ; print err - } - Right x -> print x - } - where - root = "" - - -main = test "test" - - diff --git a/Text/ParserCombinators/Parsec/examples/Henk/test.h b/Text/ParserCombinators/Parsec/examples/Henk/test.h deleted file mode 100644 index d69d4e0c0..000000000 --- a/Text/ParserCombinators/Parsec/examples/Henk/test.h +++ /dev/null @@ -1,47 +0,0 @@ --- type declarations -data List: * -> * - = { Nil: \/a. List a - ; Cons : \/a. a -> List a -> List a - }; - -data Maybe : * -> * -> * - = { Left: \/a,b. a -> Maybe a b - ; Right: \/a,b. b -> Maybe a b - } - --- value declarations -let id : \/a. a->a - = /\a. \x:a. x; - -letrec { map: \/a,b. a -> b -> List a -> List b - = /\a,b. - \f: a->b,xs:List a. - case (xs) of - { Nil =>Nil - ; Cons => \x:a, xx: List a. - Cons (f x) (map a b f xx) - } - at {a:*} - }; - -letrec { reverse: \/a. List a -> List a - = /\a.\xs:List a. - case xs of - { Nil => Nil - ; Cons x,xx => append (reverse xx) (Cons x Nil) - } - at {a:*} - }; - -letrec { append: \/a. |~|_dummy:List a.|~|_:List a.List a - = /\a.\xs:List a, ys:List a. - case xs of - { Nil => ys - ; Cons x:a,xx: List a => Cons x (append xx ys) - } - at {a:*} - } - - - - diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/Main.hs b/Text/ParserCombinators/Parsec/examples/Mondrian/Main.hs deleted file mode 100644 index 3073a76b4..000000000 --- a/Text/ParserCombinators/Parsec/examples/Mondrian/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ ------------------------------------------------------------ --- Daan Leijen (c) 1999-2000, daan@cs.uu.nl ------------------------------------------------------------ -module Main where - -import MonParser (prettyFile) - - -main :: IO () -main = prettyFile "prelude.m" diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/MonParser.hs b/Text/ParserCombinators/Parsec/examples/Mondrian/MonParser.hs deleted file mode 100644 index 37253fd4d..000000000 --- a/Text/ParserCombinators/Parsec/examples/Mondrian/MonParser.hs +++ /dev/null @@ -1,307 +0,0 @@ ------------------------------------------------------------ --- Daan Leijen (c) 1999-2000, daan@cs.uu.nl ------------------------------------------------------------ -module MonParser ( parseMondrian - , parseMondrianFromFile - , prettyFile - - , ParseError - ) where - -import Char -import Monad -import Mondrian -import Utils (groupLambdas) - --- Parsec -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language (mondrianDef) - ---testing -import qualified SimpleMondrianPrinter as Pretty - - - - ------------------------------------------------------------ --- ------------------------------------------------------------ -parseMondrianFromFile :: String -> IO (Either ParseError CompilationUnit) -parseMondrianFromFile fname = - parseFromFile compilationUnit fname - -parseMondrian sourceName source = - parse compilationUnit sourceName source - - - --- testing -prettyFile fname - = do{ result <- parseMondrianFromFile fname - ; case result of - Left err -> putStr ("parse error at: " ++ show err) - Right x -> print (Pretty.compilationUnit x) - } - - ------------------------------------------------------------ --- GRAMMAR ELEMENTS ------------------------------------------------------------ -compilationUnit :: Parser CompilationUnit -compilationUnit = - do{ whiteSpace - ; reserved "package" - ; name <- option [""] packageName - ; decls <- option [] declarations - ; eof - ; return $ Package name decls - } - ------------------------------------------------------------ --- Declarations ------------------------------------------------------------ -declarations = - braces (semiSep1 declaration) - -declaration = - importDeclaration - <|> classDeclaration - <|> variableSignatureDeclaration - "declaration" - -variableSignatureDeclaration = - do{ name <- variableName - ; variableDeclaration name <|> signatureDeclaration name - } - -variableDeclaration name = - do{ symbol "=" - ; expr <- expression - ; return $ VarDecl name expr - } - "variable declaration" - -importDeclaration = - do{ reserved "import" - ; name <- packageName - ; star <- option [] (do{ symbol "." - ; symbol "*" - ; return ["*"] - }) - ; return $ ImportDecl (name ++ star) - } - -classDeclaration = - do{ reserved "class" - ; name <- className - ; extends <- option [] (do{ reserved "extends" - ; n <- className - ; return [n] - }) - ; decls <- option [] declarations - ; return $ ClassDecl name extends decls - } - -signatureDeclaration name = - do{ symbol "::" - ; texpr <- typeExpression - ; return $ SigDecl name texpr - } - "type declaration" - - ------------------------------------------------------------ --- Expressions ------------------------------------------------------------ -expression :: Parser Expr -expression = - lambdaExpression - <|> letExpression - <|> newExpression - <|> infixExpression - "expression" - -lambdaExpression = - do{ symbol "\\" - ; name <- variableName - ; symbol "->" - ; expr <- expression - ; return $ groupLambdas (Lambda [name] expr) - } - -letExpression = - do{ reserved "let" - ; decls <- declarations - ; reserved "in" - ; expr <- expression - ; return $ Let decls expr - } - -newExpression = - do{ reserved "new" - ; name <- className - ; decls <- option [] declarations - ; return $ New name decls - } - - ------------------------------------------------------------ --- Infix expression ------------------------------------------------------------ -infixExpression = - buildExpressionParser operators applyExpression - -operators = - [ [ prefix "-", prefix "+" ] - , [ op "^" AssocRight ] - , [ op "*" AssocLeft, op "/" AssocLeft ] - , [ op "+" AssocLeft, op "-" AssocLeft ] - , [ op "==" AssocNone, op "/=" AssocNone, op "<" AssocNone - , op "<=" AssocNone, op ">" AssocNone, op ">=" AssocNone ] - , [ op "&&" AssocNone ] - , [ op "||" AssocNone ] - ] - where - op name assoc = Infix (do{ var <- try (symbol name) - ; return (\x y -> App (App (Var [var]) x) y) - }) assoc - prefix name = Prefix (do{ var <- try (symbol name) - ; return (\x -> App (Var [var,"unary"]) x) - }) - - - -applyExpression = - do{ exprs <- many1 simpleExpression - ; return (foldl1 App exprs) - } - -{- -infixExpression = - do{ (e,es) <- chain simpleExpression operator "infix expression" - ; return $ if null es then e else (unChain (Chain e es)) - } --} - -simpleExpression :: Parser Expr -simpleExpression = - literal - <|> parens expression - <|> caseExpression - <|> variable - "simple expression" - - ------------------------------------------------------------ --- Case expression ------------------------------------------------------------ -caseExpression = - do{ reserved "case" - ; expr <- variable - ; reserved "of" - ; alts <- alternatives - ; return $ Case expr alts - } - -alternatives = - braces (semiSep1 arm) - -arm = - do{ pat <- pattern - ; symbol "->" - ; expr <- expression - ; return (pat,expr) - } - -pattern = - do{ reserved "default" - ; return Default - } - <|> do{ name <- patternName - ; decls <- option [] declarations - ; return $ Pattern name decls - } - "pattern" - - ------------------------------------------------------------ --- Type expression ------------------------------------------------------------ - -{- -typeExpression = - do{ (e,es) <- chain simpleType typeOperator "type expression" - ; return $ if null es then e else Chain e es - } - "type expression" --} - -typeExpression :: Parser Expr -typeExpression = - do{ exprs <- sepBy1 simpleType (symbol "->") - ; return (foldl1 (\x y -> App (App (Var ["->"]) x) y) exprs) - } - -simpleType :: Parser Expr -simpleType = - parens typeExpression - <|> variable - "simple type" - - - ------------------------------------------------------------ --- LEXICAL ELEMENTS ------------------------------------------------------------ - - ------------------------------------------------------------ --- Identifiers & Reserved words ------------------------------------------------------------ -variable = - do{ name <- variableName - ; return $ Var name - } - -patternName = qualifiedName "pattern variable" -variableName = qualifiedName "identifier" -className = qualifiedName "class name" -packageName = qualifiedName "package name" - -qualifiedName = - identifier `sepBy1` (symbol "." "") - - ------------------------------------------------------------ --- Literals ------------------------------------------------------------ -literal = - do{ v <- intLiteral <|> chrLiteral <|> strLiteral - ; return $ Lit v - } - "literal" - -intLiteral = do{ n <- natural; return (IntLit n) } -chrLiteral = do{ c <- charLiteral; return (CharLit c) } -strLiteral = do{ s <- stringLiteral; return (StringLit s) } - - - ------------------------------------------------------------ --- Tokens --- Use qualified import to have token parsers on toplevel ------------------------------------------------------------ -mondrian = P.makeTokenParser mondrianDef - -parens = P.parens mondrian -braces = P.braces mondrian -semiSep1 = P.semiSep1 mondrian -whiteSpace = P.whiteSpace mondrian -symbol = P.symbol mondrian -identifier = P.identifier mondrian -reserved = P.reserved mondrian -natural = P.natural mondrian -charLiteral = P.charLiteral mondrian -stringLiteral = P.stringLiteral mondrian diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/Mondrian.hs b/Text/ParserCombinators/Parsec/examples/Mondrian/Mondrian.hs deleted file mode 100644 index d8e3c5a0b..000000000 --- a/Text/ParserCombinators/Parsec/examples/Mondrian/Mondrian.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- -Abstract Syntax for Core Mondrian -(c) 1999 Erik Meijer and Arjan van Yzendoorn --} - -module Mondrian where - -data CompilationUnit - = Package Name [Decl] - deriving Show - -data Decl - = ClassDecl Name [Name] [Decl] - | ImportDecl Name - | VarDecl Name Expr - | SigDecl Name Expr - deriving Show - -data Expr - = Lit Lit - | Var Name - | Case Expr [(Pattern, Expr)] - | Let [Decl] Expr - | Lambda [Name] Expr - | App Expr Expr - | New Name [Decl] - | Chain Expr [(Name, Expr)] - deriving Show - -data Pattern - = Pattern Name [Decl] - | Default - deriving Show - -data Lit - = IntLit Integer - | CharLit Char - | StringLit String - deriving Show - -type Name = [String] diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/Prelude.m b/Text/ParserCombinators/Parsec/examples/Mondrian/Prelude.m deleted file mode 100644 index f550690c9..000000000 --- a/Text/ParserCombinators/Parsec/examples/Mondrian/Prelude.m +++ /dev/null @@ -1,46 +0,0 @@ -package Prelude -{ import Foo - -; class List extends Mondrian -; class Nil extends List -; class Cons extends List - { head :: Mondrian - ; tail :: List - } - -; map = \f -> \as -> - case as of - { Nil -> new Nil - ; Cons{ a :: Mondrian; a = head; as :: List; as = tail } -> - new Cons{ head = f a; tail = map f as } - } - -; class Boolean extends Mondrian -; class True extends Boolean -; class False extends Boolean - -; cond = \b -> \t -> \e -> - case b of - { True -> t - ; False -> e - } - -; fac = \n -> cond (n == 0) 1 (n * (fac (n - 1))) - -; I :: a -> a -; I = \x -> x - -; K :: a -> b -> a -; K = \x -> \y -> x - -; S :: (a -> b -> c) -> (a -> b) -> (a -> c) -; S = \f -> \g -> \x -> f x (g x) - -; Compose :: (b -> c) -> (a -> b) -> (a -> c) -; Compose = \f -> \g -> \x -> f (g x) - -; Twice :: (a -> a) -> (a -> a) -; Twice = \f -> Compose f f - -; main = Twice I 3 -} \ No newline at end of file diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/Pretty.hs b/Text/ParserCombinators/Parsec/examples/Mondrian/Pretty.hs deleted file mode 100644 index 5b399e8dc..000000000 --- a/Text/ParserCombinators/Parsec/examples/Mondrian/Pretty.hs +++ /dev/null @@ -1,161 +0,0 @@ -{- -Copyright(C) 1999 Erik Meijer --} -module Pretty where - -{- - -Quick reference for the simple Pretty-print Combinators - - |---| |----| |-------| - |koe| <|> |beer| = |koebeer| - |---| |----| |-------| - - |---| |----| |--------| - |koe| <+> |beer| = |koe beer| - |---| |----| |--------| - - |---| |----| |----| - |koe| <-> |beer| = |koe | - |---| |----| |beer| - |----| - - |---| |----| |-------| - |koe| <|> nest 2 |beer| = |koebeer| - |---| |----| |-------| - - |---| |----| |------| - |koe| <-> nest 2 |beer| = |koe | - |---| |----| | beer| - |------| - - empty = --} - -{- - -Extremely simplified version of John Hughes' combinators, -without (sep), but with (empty). - -TODO: use Okasaki-style catenable dequeues to represent Doc - -(c) Erik Meijer and Arjan van IJzendoorn - -October 199 - --} - -infixl 7 <+> -infixl 6 <|> -infixr 5 <-> - -instance Show Doc where - { showsPrec = showsPrecDoc } - -showsPrecDoc i = \d -> - case d of - { Empty -> id - ; Doc ds -> layout ds - } - -data Doc - = Doc [(Int,ShowS)] - | Empty - -layout :: [(Int,ShowS)] -> ShowS -layout = \ds -> - case ds of - { [] -> showString "" - ; [(n,s)] -> indent n.s - ; (n,s):ds -> indent n.s.showString "\n".layout ds - } - -width :: Doc -> Int -width = \d -> - case d of - { Empty -> 0 - ; Doc ds -> maximum [ i + length (s "") | (i,s) <- ds ] - } - -text :: String -> Doc -text = \s -> Doc [(0,showString s)] - -nest :: Int -> Doc -> Doc -nest n = \d -> - case d of - { Empty -> Empty - ; Doc ds -> Doc [ (i+n,d) | (i,d) <- ds ] - } - -(<->) :: Doc -> Doc -> Doc -Empty <-> Empty = Empty -Empty <-> (Doc d2) = Doc d2 -(Doc d1) <-> Empty = Doc d1 -(Doc d1) <-> (Doc d2) = Doc (d1++d2) - -(<+>) :: Doc -> Doc -> Doc -a <+> b = a <|> (text " ") <|> b - -(<|>) :: Doc -> Doc -> Doc -Empty <|> Empty = Empty -Empty <|> (Doc d2) = Doc d2 -(Doc d1) <|> Empty = Doc d1 -(Doc d1) <|> (Doc d2) = - let - { (d,(i,s)) = (init d1,last d1) - ; ((j,t),e) = (head d2,tail d2) - } - in - ( Doc d - <-> Doc [(i,s.t)] - <-> nest (i + length (s "") - j) (Doc e) - ) - --- Derived operations - -empty :: Doc -empty = Empty - -{- - -horizontal s [a,b,c] = - a <|> (s <|> b) <|> (s <|> c) - --} - -horizontal :: Doc -> [Doc] -> Doc -horizontal s = \ds -> - case ds of - { [] -> empty - ; ds -> foldr1 (\d -> \ds -> d <|> s <|> ds) ds - } - -{- - -vertical s [a,b,c] = - a - <-> - (s <|> b) - <-> - (s <|> c) - --} - -vertical :: [Doc] -> Doc -vertical = \ds -> - case ds of - { [] -> empty - ; d:ds -> d <-> vertical ds - } - -block (o,s,c) = \ds -> - case ds of - { [] -> o<|>c - ; [d] -> o<|>d<|>c ; d:ds -> (vertical ((o <|> d):[s <|> d | d <- ds ])) <-> c - } - --- Helper function - -indent :: Int -> ShowS -indent = \n -> - showString [ ' ' | i <- [1..n] ] diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/SimpleMondrianPrinter.hs b/Text/ParserCombinators/Parsec/examples/Mondrian/SimpleMondrianPrinter.hs deleted file mode 100644 index b3c6f8692..000000000 --- a/Text/ParserCombinators/Parsec/examples/Mondrian/SimpleMondrianPrinter.hs +++ /dev/null @@ -1,162 +0,0 @@ -{- -Copyright(C) 1999 Erik Meijer and Arjan van Yzendoorn --} -module SimpleMondrianPrinter where - -import Mondrian -import Pretty -import Utils - -mondrianIndent :: Int -mondrianIndent = 2 - -compilationUnit :: CompilationUnit -> Doc -compilationUnit = \m -> - case m of - { Package n ds -> package m (name n) (decls ds) - } - -package = \(Package n' ds') -> \n -> \ds -> - case null ds' of - { True -> text "package" <+> n <+> row ds - ; False -> text "package" <+> n <-> nest (-mondrianIndent) (column ds) - } - -decls = \ds -> [ decl d | d <- ds ] - -decl = \d -> - case d of - { ImportDecl ns -> importDecl d (name ns) - ; ClassDecl n xs ds -> classDecl d (name n) (extends xs) (decls ds) - ; SigDecl n t -> sigDecl (name n) (expr t) - ; VarDecl v (Lambda ns e) -> varDecl d (name v) (lambdas ns) (expr e) - ; VarDecl v e -> decl (VarDecl v (Lambda [] e)) - } - -extends = \xs -> - case xs of - { [] -> empty - ; [x] -> text "extends" <+> name x <+> empty - ; xs -> text "multiple inheritance not supported" <+> row [name x | x <- xs] - } - -classDecl = \(ClassDecl n' xs' ds') -> \n -> \xs -> \ds -> - case ds' of - { [] -> text "class" <+> n <+> xs - ; otherwise -> text "class" <+> n <+> xs <-> column ds - } - -sigDecl = \n -> \t -> n <+> text "::" <+> t - -importDecl = \d -> \n -> text "import" <+> n - -varDecl = \(VarDecl v' (Lambda ns' e')) -> \v -> \ns -> \e -> - if isSimpleExpr e' - then v <+> text "=" <+> ns <|> e - else v <+> text "=" <+> ns <-> nest mondrianIndent e - -names = \ns -> horizontal (text " ") [ name n | n <- ns ] - -name = \ns -> horizontal (text ".") [text n | n <- ns] - -lambdas = \ns -> - case ns of - { [] -> empty - ; [n] -> text "\\" <|> name n <+> text "->" <+> empty - ; n:ns -> text "\\" <|> name n <+> text "->" <+> lambdas ns - } - -expr = \e -> - case e of - { Lit l -> lit l - ; Var n -> name n - ; App f a -> application (expr f) (expr a) - ; Lambda ns b -> lambdaExpr e (lambdas ns) (expr b) - ; New n ds -> newExpr e (name n) (decls ds) - ; Case e1 as -> caseExpr e (expr e1) (arms as) - ; Let ds e1 -> letExpr e (decls ds) (expr e1) - ; Chain e1 oes -> chain e1 oes - } - -application = \f -> \a -> text "(" <|> f <+> a <|> text ")" - -newExpr = \(New n' ds') -> \n -> \ds -> - case ds' of - { [] -> text "new" <+> n - ; otherwise -> - if isSimpleDecls ds' - then text "new" <+> n <+> row ds - else text "new" <+> n <-> column ds - } - -lambdaExpr = \(Lambda ns' e') -> \ns -> \e -> - if isSimpleExpr e' - then ns <|> e - else ns <-> nest mondrianIndent e - -caseExpr :: Expr -> Doc -> [Doc] -> Doc -caseExpr = \(Case e' as') -> \e -> \as -> - case (isSimpleExpr e', isSimpleArms as') of - { (True, True) -> text "case" <+> e <+> text "of" <+> row as - ; (True, False)-> text "case" <+> e <+> text "of" <-> column as - ; (False, True) -> text "case" <-> nest mondrianIndent e <-> text "of" <+> row as - ; (False, False) -> text "case" <-> nest mondrianIndent e <-> text "of" <-> column as - } - -letExpr = \(Let ds' e') -> \ds -> \e -> - case (length ds' == 1 && isSimpleDecls ds', isSimpleExpr e') of - { (True, True) -> text "let" <+> row ds <+> text "in" <+> e - ; (True, False) -> text "let" <+> row ds <-> text "in" <-> nest mondrianIndent e - ; (False, True) -> text "let" <-> column ds <-> text "in" <+> e - ; (False, False) -> text "let" <-> column ds <-> text "in" <-> nest mondrianIndent e - } - -arms = \as -> [ arm (p,e) (pattern p) (expr e) | (p,e) <- as ] - -arm = \(p',e') -> \p -> \e -> - if isSimplePattern p' && isSimpleExpr e' - then p <+> text "->" <+> e - else p <+> text "->" <-> nest mondrianIndent e - --- This is a dirty hack! - -chain = \e -> \oes -> - case oes of - { [] -> bracket e - ; ([""],f):oes -> if (isSimpleExpr f) - then (bracket e) <+> chain f oes - else (bracket e) <-> nest 2 (chain f oes) - ; (o,f):oes -> if (isSimpleExpr f) - then (bracket e) <+> name o <+> chain f oes - else (bracket e) <-> name o <+> chain f oes - } - -pattern = \p -> - case p of - { Pattern n ds -> - case ds of - { [] -> name n - ; otherwise -> name n <+> row (decls ds) - } - ; Default -> text "default" - } - -lit = \l -> - case l of - { IntLit i -> text (show i) - ; CharLit c -> text (show c) - ; StringLit s -> text (show s) - } - -bracket = \e -> - case e of - { Lit l -> expr e - ; Var n -> expr e - ; e -> par (expr e) - } - -par = \e -> text "(" <|> e <|> text ")" - -column = \ds -> nest mondrianIndent (block (text "{ ", text ";" <+> empty, text "}") ds) - -row = \ds -> text "{" <|> horizontal (text ";" <+> empty) ds <|> text "}" \ No newline at end of file diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/Utils.hs b/Text/ParserCombinators/Parsec/examples/Mondrian/Utils.hs deleted file mode 100644 index 00d905690..000000000 --- a/Text/ParserCombinators/Parsec/examples/Mondrian/Utils.hs +++ /dev/null @@ -1,61 +0,0 @@ -{- -Copyright(C) 1999 Erik Meijer and Arjan van Yzendoorn - -Determines wether an express/declaration is "simple". -The pretty-printing strategy is to print a "complex" expression -on a new line. --} - -module Utils where - -import Mondrian - -isSimpleExpr :: Expr -> Bool -isSimpleExpr = \e -> - case e of - { Lit l -> True - ; Var n -> True - ; Case e as -> and [ isSimpleArms as, isSimpleExpr e ] - ; Let ds e -> and [ isSimpleDecls ds, isSimpleExpr e ] - ; Lambda n e -> isSimpleExpr e - ; New n ds -> all isSimpleDecl ds - ; App f a -> and [ isSimpleExpr f, isSimpleExpr a] - ; Chain e oes -> and [ isSimpleExpr e, all isSimpleExpr [ e | (o,e) <- oes ] ] - } - -isSimpleArms = \as -> - and [ length as == 1, all isSimpleExpr [ e | (p,e) <- as ], all isSimplePattern [ p | (p,e) <- as ] ] - -isSimplePattern = \ p-> - case p of - { Pattern n ds -> isSimpleDecls ds - ; Default -> True - } - -isSimpleDecls = \ds -> - and [ all isSimpleDecl ds ] - -isSimpleDecl = \d -> - case d of - { ClassDecl n ns ds -> False - ; ImportDecl n -> True - ; VarDecl n e -> isSimpleExpr e - ; SigDecl n e -> True - } - -groupLambdas :: Expr -> Expr -groupLambdas = \e -> - case e of - { Lambda ns (Lambda ms e) -> groupLambdas (Lambda (ns++ms) e) - ; otherwise -> e - } - -isTopLevel :: [Name] -> Name -> Bool -isTopLevel = \topLevel -> \n -> - n `elem` topLevel - -topLevel :: CompilationUnit -> [Name] -topLevel = \p -> - case p of - { Package n ds -> [ n | VarDecl n e <- ds ] - } diff --git a/Text/ParserCombinators/Parsec/examples/Mondrian/test.m b/Text/ParserCombinators/Parsec/examples/Mondrian/test.m deleted file mode 100644 index 3777e0d89..000000000 --- a/Text/ParserCombinators/Parsec/examples/Mondrian/test.m +++ /dev/null @@ -1,14 +0,0 @@ -package Koe -{ -Id =\x -> /* multi-line -Comment_ */ x // the identity function -; -K = \x -> \y_ -> x - -;fac = \n -> - case n of - { n -> n - ; n -> let { m = minus n 1 } in times n (fac m) - } -; class Hi extends Mondrian { x = 2} -} diff --git a/Text/ParserCombinators/Parsec/examples/UserGuide/Main.hs b/Text/ParserCombinators/Parsec/examples/UserGuide/Main.hs deleted file mode 100644 index db4f26dd0..000000000 --- a/Text/ParserCombinators/Parsec/examples/UserGuide/Main.hs +++ /dev/null @@ -1,181 +0,0 @@ ------------------------------------------------------------ --- Daan Leijen (c) 2000, daan@cs.uu.nl ------------------------------------------------------------ -module Main where - -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr -import Text.ParserCombinators.Parsec.Token -import Text.ParserCombinators.Parsec.Language - - - ------------------------------------------------------------ --- ------------------------------------------------------------ -run :: Show a => Parser a -> String -> IO () -run p input - = case (parse p "" input) of - Left err -> do{ putStr "parse error at " - ; print err - } - Right x -> print x - - -runLex :: Show a => Parser a -> String -> IO () -runLex p - = run (do{ whiteSpace lang - ; x <- p - ; eof - ; return x - } - ) - ------------------------------------------------------------ --- Sequence and choice ------------------------------------------------------------ -simple :: Parser Char -simple = letter - -openClose :: Parser Char -openClose = do{ char '(' - ; char ')' - } - -matching:: Parser () -matching= do{ char '(' - ; matching - ; char ')' - ; matching - } - <|> return () - - --- Predictive parsing -testOr = do{ char '('; char 'a'; char ')' } - <|> do{ char '('; char 'b'; char ')' } - -testOr1 = do{ char '(' - ; char 'a' <|> char 'b' - ; char ')' - } - -testOr2 = try (do{ char '('; char 'a'; char ')' }) - <|> do{ char '('; char 'b'; char ')' } - - --- Semantics -nesting :: Parser Int -nesting = do{ char '(' - ; n <- nesting - ; char ')' - ; m <- nesting - ; return (max (n+1) m) - } - <|> return 0 - -word1 :: Parser String -word1 = do{ c <- letter - ; do{ cs <- word1 - ; return (c:cs) - } - <|> return [c] - } - ------------------------------------------------------------ --- ------------------------------------------------------------ - -word :: Parser String -word = many1 (letter "") "word" - -sentence :: Parser [String] -sentence = do{ words <- sepBy1 word separator - ; oneOf ".?!" "end of sentence" - ; return words - } - -separator :: Parser () -separator = skipMany1 (space <|> char ',' "") - - ------------------------------------------------------------ --- Tokens ------------------------------------------------------------ -lang = makeTokenParser - (haskellStyle{ reservedNames = ["return","total"]}) - - ------------------------------------------------------------ --- ------------------------------------------------------------ -expr = buildExpressionParser table factor - "expression" - -table = [[op "*" (*) AssocLeft, op "/" div AssocLeft] - ,[op "+" (+) AssocLeft, op "-" (-) AssocLeft] - ] - where - op s f assoc - = Infix (do{ symbol lang s; return f} "operator") assoc - -factor = parens lang expr - <|> natural lang - "simple expression" - - -test1 = do{ n <- natural lang - ; do{ symbol lang "+" - ; m <- natural lang - ; return (n+m) - } - <|> return n - } - ------------------------------------------------------------ --- ------------------------------------------------------------ -{- -receipt ::= product* total -product ::= "return" price ";" - | identifier price ";" -total ::= price "total" -price ::= natural "." digit digit --} - -receipt :: Parser Bool -receipt = do{ ps <- many produkt - ; p <- total - ; return (sum ps == p) - } - -produkt = do{ reserved lang "return" - ; p <- price - ; semi lang - ; return (-p) - } - <|> do{ identifier lang - ; p <- price - ; semi lang - ; return p - } - "product" - -total = do{ p <- price - ; reserved lang "total" - ; return p - } - -price :: Parser Int -price = lexeme lang ( - do{ ds1 <- many1 digit - ; char '.' - ; ds2 <- count 2 digit - ; return (convert 0 (ds1 ++ ds2)) - }) - "price" - where - convert n [] = n - convert n (d:ds) = convert (10*n + digitToInt d) ds - - diff --git a/Text/ParserCombinators/Parsec/examples/tiger/Main.hs b/Text/ParserCombinators/Parsec/examples/tiger/Main.hs deleted file mode 100644 index 0029171eb..000000000 --- a/Text/ParserCombinators/Parsec/examples/tiger/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -{--------------------------------------------------------------- -Daan Leijen (c) 2001. daan@cs.uu.nl - -$Revision: 1.1 $ -$Author: panne $ -$Date: 2002/05/31 12:22:35 $ ----------------------------------------------------------------} -module Main where - -import Tiger( prettyTigerFromFile ) - -main = prettyTigerFromFile "fac.tig" diff --git a/Text/ParserCombinators/Parsec/examples/tiger/Tiger.hs b/Text/ParserCombinators/Parsec/examples/tiger/Tiger.hs deleted file mode 100644 index 7849cab15..000000000 --- a/Text/ParserCombinators/Parsec/examples/tiger/Tiger.hs +++ /dev/null @@ -1,347 +0,0 @@ -------------------------------------------------------------- --- Parser for Tiger from Appel's book on compilers. --- Semantic checks have been omitted for now. --- Scope rules and such are as a consequence not implemented. -------------------------------------------------------------- - -module Tiger( prettyTigerFromFile ) where - -import TigerAS -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language( javaStyle ) - - -prettyTigerFromFile fname - = do{ input <- readFile fname - ; putStr input - ; case parse program fname input of - Left err -> do{ putStr "parse error at " - ; print err - } - Right x -> print x - } - -{- -main = do putStr "Parsec Tiger parser\n" - putStr "Type filename (without suffix): " - basename <- getLine - tokens <- scanner False keywordstxt - keywordsops - specialchars - opchars - (basename ++ ".sl") - Nothing - let ((exprpp,proof), errors) = parse pRoot tokens - putStr (if null errors then "" else "Errors:\n" ++ errors) - putStr ("Result:\n" ++ (disp exprpp 140 "")) - writeFile (basename ++ ".tex") (disp proof 500 "") - putStr ("\nGenerated proof in file " ++ (basename ++ ".tex")) --} - ------------------------------------------------------------ --- A program is simply an expression. ------------------------------------------------------------ -program - = do{ whiteSpace - ; e <- expr - ; return e - } - ----------------------------------------------------------------- --- Declarations for types, identifiers and functions ----------------------------------------------------------------- -decs - = many dec - -dec - = tydec - <|> - vardec - <|> - fundec - ----------------------------------------------------------------- --- Type declarations --- int and string are predefined, but not reserved. ----------------------------------------------------------------- -tydec :: Parser Declaration -tydec - = do{ reserved "type" - ; tid <- identifier - ; symbol "=" - ; t <- ty - ; return (TypeDec tid t) - } - -ty - = do{ fields <- braces tyfields - ; return (Record fields) - } - <|> - do{ reserved "array" - ; reserved "of" - ; tid <- identifier - ; return (Array tid) - } - <|> - do{ id <- identifier - ; return (Var id) - } - -tyfields - = commaSep field - -noType = "*" -voidType = "void" - -field - = do{ id <- identifier - ; symbol ":" - ; tid <- identifier - ; return (TypedVar id tid) - } - ----------------------------------------------------------------- --- identifier declarations --- Lacks: 11, 12 ----------------------------------------------------------------- -vardec - = do{ reserved "var" - ; id <- identifier - ; t <- option noType (try (do{ symbol ":" - ; identifier - })) - ; symbol ":=" - ; e <- expr - ; return (VarDec id t e) - } - ----------------------------------------------------------------- --- Function declarations ----------------------------------------------------------------- -fundec - = do{ reserved "function" - ; name <- identifier - ; parms <- parens tyfields - ; rettype <- option voidType (do{ symbol ":" - ; identifier - }) - ; symbol "=" - ; body <- expr - ; return (FunDec name parms rettype body) - } - ----------------------------------------------------------------- --- Lvalues --- This may not be what we want. I parse lvalues as --- a list of dot separated array indexings (where the indexing) --- may be absent. Possibly, we'd want the . and [] ----------------------------------------------------------------- - --- This combinator does ab* in a leftassociative way. --- Applicable when you have a cfg rule with left recursion --- which you might rewrite into EBNF X -> YZ*. -lfact :: Parser a -> Parser (a -> a) -> Parser a -lfact p q = do{ a <- p - ; fs <- many q - ; return (foldl (\x f -> f x) a fs) - } -{- -chainl op expr = lfact expr (do { o <- op - ; e <- expr - ; return (`o` e) - }) - -} -lvalue = lfact variable (recordref <|> subscripted) - -recordref = do{ symbol "." - ; id <- variable - ; return (\x -> Dot x id) - } -subscripted = do{ indexexpr <- brackets expr - ; return (\x -> Sub x indexexpr) - } - -{- Alternatively (an lvalue is then a sequence of, possibly (mutli-)indexed, identifiers separated by dots) -lvalue :: Parser Expr -lvalue = do{ flds <- sepBy1 subscripted (symbol ".") - ; return (if length flds < 2 then head flds else Dots flds) - } -subscripted :: Parser Expr -subscripted = do{ id <- identifier - ; indexes <- many (brackets expr) - ; return (if null indexes then Ident id - else Subscripted id indexes) - } --} - ----------------------------------------------------------------- --- All types of expression(s) ----------------------------------------------------------------- - -exprs = many expr - -expr :: Parser Expr -expr = choice - [ do{ reserved "break" - ; return Break - } - , ifExpr - , whileExpr - , forExpr - , letExpr - , sequenceExpr - , infixExpr --- , sequenceExpr -- I am not sure about this one. - ] - -recordExpr :: Parser Expr -recordExpr = do{ tid <- identifier - ; symbol "{" - ; fields <- commaSep1 fieldAssign - ; symbol "}" - ; return (RecordVal tid fields) - } - -fieldAssign :: Parser AssignField -fieldAssign = do{ id <- identifier - ; symbol "=" - ; e <- expr - ; return (AssignField id e) - } - -arrayExpr :: Parser Expr -arrayExpr = do{ tid <- identifier - ; size <- brackets expr - ; reserved "of" - ; initvalue <- expr - ; return (ArrayVal tid size initvalue) - } - -assignExpr :: Parser Expr -assignExpr = do{ lv <- lvalue - ; symbol ":=" - ; e <- expr - ; return (Assign lv e) - } - -ifExpr :: Parser Expr -ifExpr = do{ reserved "if" - ; cond <- expr - ; reserved "then" - ; thenpart <- expr - ; elsepart <- option Skip (do{ reserved "else"; expr}) - ; return (If cond thenpart elsepart) - } - -whileExpr :: Parser Expr -whileExpr = do{ reserved "while" - ; cond <- expr - ; reserved "do" - ; body <- expr - ; return (While cond body) - } - -forExpr :: Parser Expr -forExpr = do{ reserved "for" - ; id <- identifier - ; symbol ":=" - ; lowerbound <- expr - ; reserved "to" - ; upperbound <- expr - ; reserved "do" - ; body <- expr - ; return (For id lowerbound upperbound body) - } - -letExpr :: Parser Expr -letExpr = do{ reserved "let" - ; ds <- decs - ; reserved "in" - ; es <- semiSep expr - ; reserved "end" - ; return (Let ds es) - } - -sequenceExpr :: Parser Expr -sequenceExpr = do{ exps <- parens (semiSep1 expr) - ; return (if length exps < 2 then head exps else Seq exps) - } - -infixExpr :: Parser Expr -infixExpr = buildExpressionParser operators simpleExpr - -operators = - [ [ prefix "-"] - , [ op "*" AssocLeft, op "/" AssocLeft ] - , [ op "+" AssocLeft, op "-" AssocLeft ] - , [ op "=" AssocNone, op "<>" AssocNone, op "<=" AssocNone - , op "<" AssocNone, op ">=" AssocNone, op ">" AssocNone ] - , [ op "&" AssocRight ] -- Right for shortcircuiting - , [ op "|" AssocRight ] -- Right for shortcircuiting - , [ op ":=" AssocRight ] - ] - where - op name assoc = Infix (do{ reservedOp name - ; return (\x y -> Op name x y) - }) assoc - prefix name = Prefix (do{ reservedOp name - ; return (\x -> UnOp name x) - }) - -simpleExpr = choice [ do{ reserved "nil" - ; return Nil - } - , intLiteral - , strLiteral - , parens expr - , try funCallExpr - , try recordExpr - , try arrayExpr - , lvalue - ] - -funCallExpr = do{ id <- identifier - ; parms <- parens (commaSep expr) - ; return (Apply id parms) - } - -intLiteral = do{ i <- integer; return (IntLit i) } -strLiteral = do{ s <- stringLiteral; return (StringLit s) } -variable = do{ id <- identifier - ; return (Ident id) - } - - ------------------------------------------------------------ --- The lexer ------------------------------------------------------------ -lexer = P.makeTokenParser tigerDef - -tigerDef = javaStyle - { -- Kept the Java single line comments, but officially the language has no comments - P.reservedNames = [ "array", "break", "do", "else", "end", "for", "function", - "if", "in", "let", - "nil", "of", "then", "to", "type", "var", "while" ] - , P.reservedOpNames= [ "<", "<=", ">", ">=", ":=", "+", "&", "-", "/"] - , P.opLetter = oneOf (concat (P.reservedOpNames tigerDef)) - , P.caseSensitive = True - } - -parens = P.parens lexer -braces = P.braces lexer -semiSep = P.semiSep lexer -semiSep1 = P.semiSep1 lexer -commaSep = P.commaSep lexer -commaSep1 = P.commaSep1 lexer -brackets = P.brackets lexer -whiteSpace = P.whiteSpace lexer -symbol = P.symbol lexer -identifier = P.identifier lexer -reserved = P.reserved lexer -reservedOp = P.reservedOp lexer -integer = P.integer lexer -charLiteral = P.charLiteral lexer -stringLiteral = P.stringLiteral lexer diff --git a/Text/ParserCombinators/Parsec/examples/tiger/TigerAS.hs b/Text/ParserCombinators/Parsec/examples/tiger/TigerAS.hs deleted file mode 100644 index 138ed2f22..000000000 --- a/Text/ParserCombinators/Parsec/examples/tiger/TigerAS.hs +++ /dev/null @@ -1,43 +0,0 @@ -module TigerAS where - -type VarIdent = String -type TypeIdent = String - -data Declaration = TypeDec TypeIdent Type | VarDec VarIdent TypeIdent Expr | FunDec VarIdent [TypedVar] TypeIdent Expr - deriving (Eq, Show) - -data TypedVar - = TypedVar VarIdent TypeIdent - deriving (Eq, Show) - -data Type - = Var TypeIdent - | Array TypeIdent - | Record [TypedVar] - deriving (Eq, Show) - -data Expr - = Sub Expr Expr - | Dot Expr Expr - | Apply VarIdent [Expr] - | Ident TypeIdent - | RecordVal TypeIdent [AssignField] - | ArrayVal TypeIdent Expr Expr - | IntLit Integer - | StringLit String - | While Expr Expr - | For VarIdent Expr Expr Expr - | If Expr Expr Expr - | Let [Declaration] [Expr] - | Assign Expr Expr - | Op String Expr Expr - | UnOp String Expr - | Skip - | Nil - | Break - | Seq [Expr] - deriving (Show, Eq) - -data AssignField - = AssignField VarIdent Expr - deriving (Eq, Show) diff --git a/Text/ParserCombinators/Parsec/examples/tiger/fac.tig b/Text/ParserCombinators/Parsec/examples/tiger/fac.tig deleted file mode 100644 index 7e8e5b711..000000000 --- a/Text/ParserCombinators/Parsec/examples/tiger/fac.tig +++ /dev/null @@ -1,4 +0,0 @@ -let function fact(n : int) : int = - if n < 1 then 1 else (n * fact(n - 1)) - in fact(10) -end diff --git a/Text/ParserCombinators/Parsec/examples/tiger/matrix.tig b/Text/ParserCombinators/Parsec/examples/tiger/matrix.tig deleted file mode 100644 index c48be3b67..000000000 --- a/Text/ParserCombinators/Parsec/examples/tiger/matrix.tig +++ /dev/null @@ -1,122 +0,0 @@ -let - -type vec = array of int -type vector = {dim : int, d : vec} - -type mat = array of vector -type matrix = {x : int, y : int, d : mat} - -function vectorCreate(n : int) : vector = - vector{dim = n, d = vec[n] of 0} - -function vectorLiftedAdd(X : vector, Y : vector) : vector = - let var tmp : vector := vectorCreate(X.dim) - in for i := 0 to X.dim do - tmp.d[i] := X.d[i] + Y.d[i]; - tmp - end - -function vectorLiftedMul(X : vector, Y : vector) : vector = - let var tmp : vector := vectorCreate(X.dim) - in for i := 0 to X.dim do - tmp.d[i] := X.d[i] * Y.d[i]; - tmp - end - -function vectorInProduct(X : vector, Y : vector) : int = - let var tmp : int := 0 - in for i := 0 to X.dim do - tmp := tmp + X.d[i] * Y.d[i]; - tmp - end - - - -function matrixCreate(n : int, m : int) : matrix = - let var tmp := matrix{x = n, y = m, d = mat[n] of nil} - in for i := 0 to n do - tmp.d[i] := vectorCreate(m); - tmp - end - -function matrixRow(A : matrix, i : int) : vector = - A.d[i] - -function matrixCol(A : matrix, j : int) : vector = - let var tmp := vectorCreate(A.y) - in for i := 0 to A.y do - tmp.d[i] := A.d[i].d[j]; - tmp - end - -function matrixTranspose(A : matrix) : matrix = - let var tmp := matrixCreate(A.y, A.x) - in for i := 0 to A.x do - for j := 0 to A.y do - tmp.d[j].d[i] := A.d[i].d[j]; - tmp - end - -function matrixLiftedAdd(A : matrix, B : matrix) : matrix = - let var tmp := matrixCreate(A.x, A.y) - in if A.x <> B.x | A.y <> B.y then exit(1) - else for i := 0 to A.x do - for j := 0 to A.y do - tmp.d[i].d[j] := A.d[i].d[j] + B.d[i].d[j]; - tmp - end - -function matrixLiftedMul(A : matrix, B : matrix) : matrix = - let var tmp := matrixCreate(A.x, A.y) - in if A.x <> B.x | A.y <> B.y then exit(1) - else for i := 0 to A.x do - for j := 0 to A.y do - tmp.d[i].d[j] := A.d[i].d[j] * B.d[i].d[j]; - tmp - end - -function matrixMul(A : matrix, B : matrix) : matrix = - let var tmp := matrixCreate(A.x, B.y) - in if A.y <> B.x then exit(1) - else for i := 0 to A.x do - for j := 0 to B.y do - tmp.d[i].d[j] := vectorInProduct(matrixRow(A,i), matrixCol(B,j)); - tmp - end - -function createDiagMat(X : vector) : matrix = - let var tmp := matrixCreate(X.dim, X.dim) - in for i := 0 to X.dim do - tmp.d[i].d[i] := X.d[i]; - tmp - end - -/* matrixMul(A, B) where B is a diagonal matrix, which can be represented - by a vector -*/ - -function matrixMulDiag(A : matrix, X : vector) : matrix = - let var tmp := matrixCreate(A.x, A.y) - in if A.y <> X.dim then exit(1) - else for i := 0 to A.x do - for j := 0 to A.y do - tmp.d[i].d[j] := A.d[i].d[j] * X.d[j]; - tmp - end - -/* Challenge: matrixMul(A, createDiagMat(X)) == matrixMulDiag(A, X) -i.e., derive the rhs from the lhs by specialization - -What are the laws involved? - -Challenge: matrixMul(A, create5shapeMatrix(a,b,c,d,e)) == efficient algorithm - -*/ - -in - - /* matrixLiftedAdd(matrixCreate(8),matrixCreate(8)) */ - - matrixMul(A, createDiagMat(X)) - -end \ No newline at end of file diff --git a/Text/ParserCombinators/Parsec/examples/tiger/merge.tig b/Text/ParserCombinators/Parsec/examples/tiger/merge.tig deleted file mode 100644 index 330474875..000000000 --- a/Text/ParserCombinators/Parsec/examples/tiger/merge.tig +++ /dev/null @@ -1,56 +0,0 @@ -let - - type any = {any : int} - var buffer := getchar() - - function readint(any: any) : int = - let var i := 0 - function isdigit(s : string) : int = - ord(buffer)>=ord("0") & ord(buffer)<=ord("9") - function skipto() = - while buffer=" " | buffer="\n" - do buffer := getchar() - in skipto(); - any.any := isdigit(buffer); - while isdigit(buffer) - do (i := i*10+ord(buffer)-ord("0"); buffer := getchar()); - i - end - - type list = {first: int, rest: list} - - function readlist() : list = - let var any := any{any=0} - var i := readint(any) - in if any.any - then list{first=i,rest=readlist()} - else nil - end - - function merge(a: list, b: list) : list = - if a=nil then b - else if b=nil then a - else if a.first < b.first - then list{first=a.first,rest=merge(a.rest,b)} - else list{first=b.first,rest=merge(a,b.rest)} - - function printint(i: int) = - let function f(i:int) = if i>0 - then (f(i/10); print(chr(i-i/10*10+ord("0")))) - in if i<0 then (print("-"); f(-i)) - else if i>0 then f(i) - else print("0") - end - - function printlist(l: list) = - if l=nil then print("\n") - else (printint(l.first); print(" "); printlist(l.rest)) - - var list1 := readlist() - var list2 := (buffer:=getchar(); readlist()) - - - /* BODY OF MAIN PROGRAM */ - in printlist(merge(list1,list2)) -end - diff --git a/Text/ParserCombinators/Parsec/examples/tiger/queens.tig b/Text/ParserCombinators/Parsec/examples/tiger/queens.tig deleted file mode 100644 index 621ec60c8..000000000 --- a/Text/ParserCombinators/Parsec/examples/tiger/queens.tig +++ /dev/null @@ -1,32 +0,0 @@ -/* A program to solve the 8-queens problem */ - -let - var N := 8 - - type intArray = array of int - - var row := intArray [ N ] of 0 - var col := intArray [ N ] of 0 - var diag1 := intArray [N+N-1] of 0 - var diag2 := intArray [N+N-1] of 0 - - function printboard() = - (for i := 0 to N-1 - do (for j := 0 to N-1 - do print(if col[i]=j then " O" else " ."); - print("\n")); - print("\n")) - - function try(c:int) = -( if c=N - then printboard() - else for r := 0 to N-1 - do if row[r]=0 & diag1[r+c]=0 & diag2[r+7-c]=0 - then (row[r]:=1; diag1[r+c]:=1; diag2[r+7-c]:=1; - col[c]:=r; - try(c+1); - row[r]:=0; diag1[r+c]:=0; diag2[r+7-c]:=0) -) - in try(0) -end - diff --git a/Text/ParserCombinators/Parsec/examples/while/Main.hs b/Text/ParserCombinators/Parsec/examples/while/Main.hs deleted file mode 100644 index d8efb82fc..000000000 --- a/Text/ParserCombinators/Parsec/examples/while/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -{--------------------------------------------------------------- -Daan Leijen (c) 2001. daan@cs.uu.nl - -$Revision: 1.1 $ -$Author: panne $ -$Date: 2002/05/31 12:22:35 $ ----------------------------------------------------------------} -module Main where - -import While( prettyWhileFromFile ) - -main = prettyWhileFromFile "fib.wh" diff --git a/Text/ParserCombinators/Parsec/examples/while/While.hs b/Text/ParserCombinators/Parsec/examples/while/While.hs deleted file mode 100644 index d686edccb..000000000 --- a/Text/ParserCombinators/Parsec/examples/while/While.hs +++ /dev/null @@ -1,179 +0,0 @@ -------------------------------------------------------------- --- Parser for WHILE from Nielson, Nielson and Hankin --- and various other sources. -------------------------------------------------------------- - -module While( prettyWhileFromFile ) where - -import WhileAS -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Expr -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language( javaStyle ) - - -prettyWhileFromFile fname - = do{ input <- readFile fname - ; putStr input - ; case parse program fname input of - Left err -> do{ putStr "parse error at " - ; print err - } - Right x -> print x - } - ---renum :: Prog -> Prog ---renum p = rn (1,p) ---rn :: (Int, Stat) -> (Int, Stat) ---rn (x,s) = case s of --- Assign vi ae _ -> (x+1,Assign vi ae x) --- Skip _ -> (x+1, Skip x) --- Seq [Stat] -> --- If be _ s1 s2 -> do{ (newx, newthen) <- rn (x+1,s1) --- ; (newerx, newelse) <- rn (newx,s2) --- ; return (newerx, If be x newthen newelse) --- } --- While be _ s -> do{ (newx, news) <- rn (x+1,s) --- ; return (newx, While be x+1 news) --- } - ------------------------------------------------------------ --- A program is simply an expression. ------------------------------------------------------------ -program - = do{ stats <- semiSep1 stat - ; return (if length stats < 2 then head stats else Seq stats) - } - -stat :: Parser Stat -stat = choice - [ do { reserved "skip"; - return (Skip 0) - } - , ifStat - , whileStat - , sequenceStat - , try assignStat - ] - - -assignStat :: Parser Stat -assignStat = do{ id <- identifier - ; symbol ":=" - ; s <- aritExpr - ; return (Assign id s 0) - } - -ifStat :: Parser Stat -ifStat = do{ reserved "if" - ; cond <- boolExpr - ; reserved "then" - ; thenpart <- stat - ; reserved "else" - ; elsepart <- stat - ; return (If cond 0 thenpart elsepart) - } - -whileStat :: Parser Stat -whileStat = do{ reserved "while" - ; cond <- boolExpr - ; reserved "do" - ; body <- stat - ; return (While cond 0 body) - } - -sequenceStat :: Parser Stat -sequenceStat = do{ stats <- parens (semiSep1 stat) - ; return (if length stats < 2 then head stats else Seq stats) - } - -boolExpr:: Parser BExp -boolExpr = buildExpressionParser boolOperators relExpr - -relExpr :: Parser BExp -relExpr = do{ arg1 <- aritExpr - ; op <- choice [string "=", try (string "<>"), try (string "<="), string "<", try (string ">="), string ">"] - ; arg2 <- aritExpr - ; return (RelOp op arg1 arg2) - } - -aritExpr :: Parser AExp -aritExpr = buildExpressionParser aritOperators simpleArit - --- Everything mapping bools to bools -boolOperators = - [ [ prefix "not"] - , [ opbb "and" AssocRight ] -- right for shortcircuit - , [ opbb "or" AssocRight ] -- right for shortcircuit - ] - where - opbb name assoc = Infix (do{ reservedOp name - ; return (\x y -> BOp name x y) - }) assoc - prefix name = Prefix (do{ reservedOp name - ; return (\x -> BUnOp name x) - }) - --- Everything mapping pairs of ints to ints -aritOperators = - [ [ op "*" AssocLeft, op "/" AssocLeft ] - , [ op "+" AssocLeft, op "-" AssocLeft ] - , [ op "&" AssocRight ] -- bitwise and delivering an int - , [ op "|" AssocRight ] -- bitwise or delivering an int - ] - where - op name assoc = Infix (do{ reservedOp name - ; return (\x y -> AOp name x y) - }) assoc - - -simpleArit = choice [ intLiteral - , parens aritExpr - , variable - ] - -simpleBool = choice [ boolLiteral - , parens boolExpr - ] - -boolLiteral = do{ reserved "false" - ; return (BoolLit True) - } - <|> - do{ reserved "true" - ; return (BoolLit False) - } - -intLiteral = do{ i <- integer; return (IntLit i) } -variable = do{ id <- identifier - ; return (Var id) - } - - ------------------------------------------------------------ --- The lexer ------------------------------------------------------------ -lexer = P.makeTokenParser whileDef - -whileDef = javaStyle - { -- Kept the Java single line comments, but officially the language has no comments - P.reservedNames = [ "true", "false", "do", "else", "not", - "if", "then", "while", "skip" - -- , "begin", "proc", "is", "end", "val", "res", "malloc" - ] - , P.reservedOpNames= [ "and", "or", "not", "<", "<=", ">", ">=", ":=", "+", "&", "-", "/"] - , P.opLetter = oneOf (concat (P.reservedOpNames whileDef)) - , P.caseSensitive = False - } - -parens = P.parens lexer -braces = P.braces lexer -semiSep1 = P.semiSep1 lexer -whiteSpace = P.whiteSpace lexer -symbol = P.symbol lexer -identifier = P.identifier lexer -reserved = P.reserved lexer -reservedOp = P.reservedOp lexer -integer = P.integer lexer -charLiteral = P.charLiteral lexer -stringLiteral = P.stringLiteral lexer diff --git a/Text/ParserCombinators/Parsec/examples/while/WhileAS.hs b/Text/ParserCombinators/Parsec/examples/while/WhileAS.hs deleted file mode 100644 index fade981bd..000000000 --- a/Text/ParserCombinators/Parsec/examples/while/WhileAS.hs +++ /dev/null @@ -1,39 +0,0 @@ -module WhileAS where - -type VarIdent = String -type Label = Int --- type Selector = String - -type Prog = Stat --- type Prog = Prog [Dec] [Stat] - --- Contains name, a list of input vars, output var, body respectively and of course --- the two labels ln and lx -data Dec = Proc [VarIdent] VarIdent VarIdent Label Stat Label - -data AExp - = Var VarIdent - | IntLit Integer - | AOp String AExp AExp --- | Var VarIdent (Maybe Selector) --- | Nil - | Dummy - deriving (Eq, Show) - -data BExp - = BUnOp String BExp - | BoolLit Bool - | BOp String BExp BExp - | RelOp String AExp AExp --- | POp VarIdent (Maybe Selector) - deriving (Eq, Show) - -data Stat - = Assign VarIdent AExp Label - | Skip Label - | Seq [Stat] - | If BExp Label Stat Stat - | While BExp Label Stat --- | Call VarIdent [AExp] VarIdent Label Label --- | Malloc VarIdent (Maybe Selector) Label - deriving (Show, Eq) diff --git a/Text/ParserCombinators/Parsec/examples/while/fac.wh b/Text/ParserCombinators/Parsec/examples/while/fac.wh deleted file mode 100644 index 12e87dd55..000000000 --- a/Text/ParserCombinators/Parsec/examples/while/fac.wh +++ /dev/null @@ -1,2 +0,0 @@ -y := x; z := 1; while y>1 do (z := z*y; y:=y-1); y:=0 - diff --git a/Text/ParserCombinators/Parsec/examples/while/fib.wh b/Text/ParserCombinators/Parsec/examples/while/fib.wh deleted file mode 100644 index 5abe13c23..000000000 --- a/Text/ParserCombinators/Parsec/examples/while/fib.wh +++ /dev/null @@ -1,11 +0,0 @@ -v := 1; -u := 1; -if n <= 2 then - skip -else - while n > 2 do ( - t := u; - u := v; - v := u + t - ) -