From: panne Date: Fri, 31 May 2002 12:22:35 +0000 (+0000) Subject: [project @ 2002-05-31 12:22:33 by panne] X-Git-Tag: nhc98-1-18-release~990 X-Git-Url: http://git.megacz.com/?p=ghc-base.git;a=commitdiff_plain;h=792c0b584d78fdab6834553b79f9b5d445ae80e6 [project @ 2002-05-31 12:22:33 by panne] Moved Parsec to its new home --- diff --git a/LICENSE b/LICENSE index 2a1ebe4..9927645 100644 --- a/LICENSE +++ b/LICENSE @@ -12,6 +12,9 @@ sources: which is (c) Manuel M. T. Chakravarty and freely redistributable (but see the full license for restrictions). + * Code from the Parsec library which is (c) Daan Leijen, and + distributable under a BSD-style license (see below). + The full text of these licenses is reproduced below. ----------------------------------------------------------------------------- @@ -80,3 +83,28 @@ the following license: be a definition of the Haskell 98 Foreign Function Interface. ----------------------------------------------------------------------------- + +Code derived from Daan Leijen's Parsec is distributed under the following +license: + + Copyright 1999-2000, Daan Leijen. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +This software is provided by the copyright holders "as is" and any express or +implied warranties, including, but not limited to, the implied warranties of +merchantability and fitness for a particular purpose are disclaimed. In no +event shall the copyright holders be liable for any direct, indirect, +incidental, special, exemplary, or consequential damages (including, but not +limited to, procurement of substitute goods or services; loss of use, data, +or profits; or business interruption) however caused and on any theory of +liability, whether in contract, strict liability, or tort (including +negligence or otherwise) arising in any way out of the use of this software, +even if advised of the possibility of such damage. diff --git a/Makefile b/Makefile index 917f0a2..5157ef1 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.28 2002/05/27 14:30:49 simonmar Exp $ +# $Id: Makefile,v 1.29 2002/05/31 12:22:33 panne Exp $ TOP=.. include $(TOP)/mk/boilerplate.mk @@ -35,6 +35,7 @@ ALL_DIRS = \ Text/Html \ Text/PrettyPrint \ Text/ParserCombinators \ + Text/ParserCombinators/Parsec \ Text/Regex \ Text/Show \ Text/Read diff --git a/Text/ParserCombinators/Parsec.hs b/Text/ParserCombinators/Parsec.hs new file mode 100644 index 0000000..76a4de9 --- /dev/null +++ b/Text/ParserCombinators/Parsec.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- 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. +-- +-- +-- This helper module exports elements from the basic libraries. +-- Inspired by: +-- +-- * Graham Hutton and Erik Meijer: +-- Monadic Parser Combinators. +-- Technical report NOTTCS-TR-96-4. +-- Department of Computer Science, University of Nottingham, 1996. +-- +-- +-- * Andrew Partridge, David Wright: +-- Predictive parser combinators need four values to report errors. +-- Journal of Functional Programming 6(2): 355-364, 1996 +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec + ( -- complete modules + module Text.ParserCombinators.Parsec.Prim + , module Text.ParserCombinators.Parsec.Combinator + , module Text.ParserCombinators.Parsec.Char + + -- module Text.ParserCombinators.Parsec.Error + , ParseError + , errorPos + + -- module Text.ParserCombinators.Parsec.Pos + , SourcePos + , SourceName, Line, Column + , sourceName, sourceLine, sourceColumn + , incSourceLine, incSourceColumn + , setSourceLine, setSourceColumn, setSourceName + + ) where + +import Text.ParserCombinators.Parsec.Pos -- textual positions +import Text.ParserCombinators.Parsec.Error -- parse errors +import Text.ParserCombinators.Parsec.Prim -- primitive combinators +import Text.ParserCombinators.Parsec.Combinator -- derived combinators +import Text.ParserCombinators.Parsec.Char -- character parsers + diff --git a/Text/ParserCombinators/Parsec/Char.hs b/Text/ParserCombinators/Parsec/Char.hs new file mode 100644 index 0000000..5f06136 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Char.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Char +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Commonly used character parsers. +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Char + ( CharParser + , spaces, space + , newline, tab + , upper, lower, alphaNum, letter + , digit, hexDigit, octDigit + , char, string + , anyChar, oneOf, noneOf + , satisfy + ) where + +import Data.Char +import Text.ParserCombinators.Parsec.Pos( updatePosChar, updatePosString ) +import Text.ParserCombinators.Parsec.Prim + +----------------------------------------------------------- +-- Type of character parsers +----------------------------------------------------------- +type CharParser st a = GenParser Char st a + +----------------------------------------------------------- +-- Character parsers +----------------------------------------------------------- +oneOf cs = satisfy (\c -> elem c cs) +noneOf cs = satisfy (\c -> not (elem c cs)) + +spaces = skipMany space "white space" +space = satisfy (isSpace) "space" + +newline = char '\n' "new-line" +tab = char '\t' "tab" + +upper = satisfy (isUpper) "uppercase letter" +lower = satisfy (isLower) "lowercase letter" +alphaNum = satisfy (isAlphaNum) "letter or digit" +letter = satisfy (isAlpha) "letter" +digit = satisfy (isDigit) "digit" +hexDigit = satisfy (isHexDigit) "hexadecimal digit" +octDigit = satisfy (isOctDigit) "octal digit" + +char c = satisfy (==c) show [c] +anyChar = satisfy (const True) + +----------------------------------------------------------- +-- Primitive character parsers +----------------------------------------------------------- +satisfy :: (Char -> Bool) -> CharParser st Char +satisfy f = tokenPrim (\c -> show [c]) + (\pos c cs -> updatePosChar pos c) + (\c -> if f c then Just c else Nothing) + +string :: String -> CharParser st String +string s = tokens show updatePosString s \ No newline at end of file diff --git a/Text/ParserCombinators/Parsec/Combinator.hs b/Text/ParserCombinators/Parsec/Combinator.hs new file mode 100644 index 0000000..e46e25b --- /dev/null +++ b/Text/ParserCombinators/Parsec/Combinator.hs @@ -0,0 +1,151 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 index 0000000..b72b65e --- /dev/null +++ b/Text/ParserCombinators/Parsec/Error.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Error +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- Parse errors +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Error + ( Message(SysUnExpect,UnExpect,Expect,Message) + , messageString, messageCompare, messageEq + + , ParseError, errorPos, errorMessages, errorIsUnknown + , showErrorMessages + + , newErrorMessage, newErrorUnknown + , addErrorMessage, setErrorPos, setErrorMessage + , mergeError + ) + where + + +import Data.List (nub,sortBy) +import Text.ParserCombinators.Parsec.Pos + +----------------------------------------------------------- +-- Messages +----------------------------------------------------------- +data Message = SysUnExpect !String --library generated unexpect + | UnExpect !String --unexpected something + | Expect !String --expecting something + | Message !String --raw message + +messageToEnum msg + = case msg of SysUnExpect _ -> 0 + UnExpect _ -> 1 + Expect _ -> 2 + Message _ -> 3 + +messageCompare msg1 msg2 + = compare (messageToEnum msg1) (messageToEnum msg2) + +messageString msg + = case msg of SysUnExpect s -> s + UnExpect s -> s + Expect s -> s + Message s -> s + +messageEq msg1 msg2 + = (messageCompare msg1 msg2 == EQ) + + +----------------------------------------------------------- +-- Parse Errors +----------------------------------------------------------- +data ParseError = ParseError !SourcePos [Message] + +errorPos :: ParseError -> SourcePos +errorPos (ParseError pos msgs) + = pos + +errorMessages :: ParseError -> [Message] +errorMessages (ParseError pos msgs) + = sortBy messageCompare msgs + +errorIsUnknown :: ParseError -> Bool +errorIsUnknown (ParseError pos msgs) + = null msgs + + +----------------------------------------------------------- +-- Create parse errors +----------------------------------------------------------- +newErrorUnknown pos + = ParseError pos [] + +newErrorMessage msg pos + = ParseError pos [msg] + +addErrorMessage msg (ParseError pos msgs) + = ParseError pos (msg:msgs) + +setErrorPos pos (ParseError _ msgs) + = ParseError pos msgs + +setErrorMessage msg (ParseError pos msgs) + = ParseError pos (msg:filter (not . messageEq msg) msgs) + + +mergeError :: ParseError -> ParseError -> ParseError +mergeError (ParseError pos msgs1) (ParseError _ msgs2) + = ParseError pos (msgs1 ++ msgs2) + + + +----------------------------------------------------------- +-- Show Parse Errors +----------------------------------------------------------- +instance Show ParseError where + show err + = show (errorPos err) ++ ":" ++ + showErrorMessages "or" "unknown parse error" + "expecting" "unexpected" "end of input" + (errorMessages err) + + +-- Language independent show function +showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs + | null msgs = msgUnknown + | otherwise = concat $ map ("\n"++) $ clean $ + [showSysUnExpect,showUnExpect,showExpect,showMessages] + where + (sysUnExpect,msgs1) = span (messageEq (SysUnExpect "")) msgs + (unExpect,msgs2) = span (messageEq (UnExpect "")) msgs1 + (expect,messages) = span (messageEq (Expect "")) msgs2 + + showExpect = showMany msgExpecting expect + showUnExpect = showMany msgUnExpected unExpect + showSysUnExpect | not (null unExpect) || + null sysUnExpect = "" + | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput + | otherwise = msgUnExpected ++ " " ++ firstMsg + where + firstMsg = messageString (head sysUnExpect) + + showMessages = showMany "" messages + + + --helpers + showMany pre msgs = case (clean (map messageString msgs)) of + [] -> "" + ms | null pre -> commasOr ms + | otherwise -> pre ++ " " ++ commasOr ms + + commasOr [] = "" + commasOr [m] = m + commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms + + commaSep = seperate ", " . clean + semiSep = seperate "; " . clean + + seperate sep [] = "" + seperate sep [m] = m + seperate sep (m:ms) = m ++ sep ++ seperate sep ms + + clean = nub . filter (not.null) + diff --git a/Text/ParserCombinators/Parsec/Expr.hs b/Text/ParserCombinators/Parsec/Expr.hs new file mode 100644 index 0000000..8f5d315 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Expr.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Expr +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/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 new file mode 100644 index 0000000..838a348 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Language.hs @@ -0,0 +1,118 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 index 0000000..6ccbec3 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Perm.hs @@ -0,0 +1,117 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 index 0000000..31391ad --- /dev/null +++ b/Text/ParserCombinators/Parsec/Pos.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 index 0000000..7ec06eb --- /dev/null +++ b/Text/ParserCombinators/Parsec/Prim.hs @@ -0,0 +1,424 @@ +----------------------------------------------------------------------------- +-- | +-- 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 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 = updateParserState id +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 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 (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 new file mode 100644 index 0000000..529eac9 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Token.hs @@ -0,0 +1,473 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Token +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/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 new file mode 100644 index 0000000..9c62dd0 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Henk/HenkAS.hs @@ -0,0 +1,151 @@ +---------------------------------------------------------------- +-- 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 new file mode 100644 index 0000000..290cda7 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Henk/HenkParser.hs @@ -0,0 +1,277 @@ +---------------------------------------------------------------- +-- 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 new file mode 100644 index 0000000..fed9adb --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Henk/Main.hs @@ -0,0 +1,37 @@ +---------------------------------------------------------------- +-- 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 new file mode 100644 index 0000000..d69d4e0 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Henk/test.h @@ -0,0 +1,47 @@ +-- 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 new file mode 100644 index 0000000..3073a76 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Mondrian/Main.hs @@ -0,0 +1,10 @@ +----------------------------------------------------------- +-- 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 new file mode 100644 index 0000000..37253fd --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Mondrian/MonParser.hs @@ -0,0 +1,307 @@ +----------------------------------------------------------- +-- 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 new file mode 100644 index 0000000..d8e3c5a --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Mondrian/Mondrian.hs @@ -0,0 +1,41 @@ +{- +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 new file mode 100644 index 0000000..f550690 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Mondrian/Prelude.m @@ -0,0 +1,46 @@ +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 new file mode 100644 index 0000000..5b399e8 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Mondrian/Pretty.hs @@ -0,0 +1,161 @@ +{- +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 new file mode 100644 index 0000000..b3c6f86 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Mondrian/SimpleMondrianPrinter.hs @@ -0,0 +1,162 @@ +{- +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 new file mode 100644 index 0000000..00d9056 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Mondrian/Utils.hs @@ -0,0 +1,61 @@ +{- +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 new file mode 100644 index 0000000..3777e0d --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/Mondrian/test.m @@ -0,0 +1,14 @@ +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 new file mode 100644 index 0000000..db4f26d --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/UserGuide/Main.hs @@ -0,0 +1,181 @@ +----------------------------------------------------------- +-- 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 new file mode 100644 index 0000000..0029171 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/tiger/Main.hs @@ -0,0 +1,12 @@ +{--------------------------------------------------------------- +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 new file mode 100644 index 0000000..7849cab --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/tiger/Tiger.hs @@ -0,0 +1,347 @@ +------------------------------------------------------------- +-- 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 new file mode 100644 index 0000000..138ed2f --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/tiger/TigerAS.hs @@ -0,0 +1,43 @@ +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 new file mode 100644 index 0000000..7e8e5b7 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/tiger/fac.tig @@ -0,0 +1,4 @@ +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 new file mode 100644 index 0000000..c48be3b --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/tiger/matrix.tig @@ -0,0 +1,122 @@ +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 new file mode 100644 index 0000000..3304748 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/tiger/merge.tig @@ -0,0 +1,56 @@ +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 new file mode 100644 index 0000000..621ec60 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/tiger/queens.tig @@ -0,0 +1,32 @@ +/* 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 new file mode 100644 index 0000000..d8efb82 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/while/Main.hs @@ -0,0 +1,12 @@ +{--------------------------------------------------------------- +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 new file mode 100644 index 0000000..d686edc --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/while/While.hs @@ -0,0 +1,179 @@ +------------------------------------------------------------- +-- 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 new file mode 100644 index 0000000..fade981 --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/while/WhileAS.hs @@ -0,0 +1,39 @@ +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 new file mode 100644 index 0000000..12e87dd --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/while/fac.wh @@ -0,0 +1,2 @@ +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 new file mode 100644 index 0000000..5abe13c --- /dev/null +++ b/Text/ParserCombinators/Parsec/examples/while/fib.wh @@ -0,0 +1,11 @@ +v := 1; +u := 1; +if n <= 2 then + skip +else + while n > 2 do ( + t := u; + u := v; + v := u + t + ) +