which is (c) Manuel M. T. Chakravarty and freely redistributable
(but see the full license for restrictions).
- * Code from the Parsec library which is (c) Daan Leijen, and
- distributable under a BSD-style license (see below).
-
The full text of these licenses is reproduced below. All of the
licenses are BSD-style or compatible.
be a definition of the Haskell 98 Foreign Function Interface.
-----------------------------------------------------------------------------
-
-Code derived from Daan Leijen's Parsec is distributed under the following
-license:
-
- Copyright 1999-2000, Daan Leijen. All rights reserved.
-
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright notice,
- this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
-
-This software is provided by the copyright holders "as is" and any express or
-implied warranties, including, but not limited to, the implied warranties of
-merchantability and fitness for a particular purpose are disclaimed. In no
-event shall the copyright holders be liable for any direct, indirect,
-incidental, special, exemplary, or consequential damages (including, but not
-limited to, procurement of substitute goods or services; loss of use, data,
-or profits; or business interruption) however caused and on any theory of
-liability, whether in contract, strict liability, or tort (including
-negligence or otherwise) arising in any way out of the use of this software,
-even if advised of the possibility of such damage.
-
------------------------------------------------------------------------------
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.46 2003/07/24 13:53:20 simonmar Exp $
+# $Id: Makefile,v 1.47 2003/07/31 17:45:22 ross Exp $
TOP=..
include $(TOP)/mk/boilerplate.mk
Text/Html \
Text/PrettyPrint \
Text/ParserCombinators \
- Text/ParserCombinators/Parsec \
Text/Regex \
Text/Show \
Text/Read
Foreign/Marshal/Utils.hs Foreign/Marshal/Error.hs \
Foreign/Marshal/Pool.hs Foreign/Marshal.hs \
Foreign/C/String.hs Foreign/C/Error.hs Foreign/C.hs Foreign.hs \
- Text/ParserCombinators/Parsec/Char.hs \
- Text/ParserCombinators/Parsec/Combinator.hs \
- Text/ParserCombinators/Parsec/Error.hs \
- Text/ParserCombinators/Parsec/Expr.hs \
- Text/ParserCombinators/Parsec/Perm.hs \
- Text/ParserCombinators/Parsec/Pos.hs \
- Text/ParserCombinators/Parsec/Prim.hs \
- Text/ParserCombinators/Parsec.hs \
Text/PrettyPrint/HughesPJ.hs Text/PrettyPrint.hs \
Text/Html/BlockTable.hs Text/Html.hs \
Text/Read.hs Text/Show.hs Text/Show/Functions.hs
# System/CPUTime.hsc System/Time.hsc
# System/Mem.hs System/Mem/StableName.hs System/Mem/Weak.hs
# System/Posix/Types.hs System/Posix/Signals.hsc
-# Text/ParserCombinators/Parsec/Token.hs \
-# Text/ParserCombinators/Parsec/Language.hs \
# Text/ParserCombinators/ReadP.hs Text/ParserCombinators/ReadPrec.hs
# Text/Read/Lex.hs
# Text/Regex/* Text/Regex.hs
$(OBJDIR)/Foreign/Marshal/Error.$O: $(OBJDIR)/Foreign/Ptr.$O
$(OBJDIR)/Foreign/C/String.$O: $(OBJDIR)/Data/Word.$O $(OBJDIR)/Foreign/Ptr.$O \
$(OBJDIR)/Foreign/Marshal/Array.$O $(OBJDIR)/Foreign/C/Types.$O
-$(OBJDIR)/Text/ParserCombinators/Parsec/Char.$O: \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Pos.$O \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Prim.$O
-$(OBJDIR)/Text/ParserCombinators/Parsec/Combinator.$O: \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Prim.$O
-$(OBJDIR)/Text/ParserCombinators/Parsec/Error.$O: \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Pos.$O
-$(OBJDIR)/Text/ParserCombinators/Parsec/Expr.$O: \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Prim.$O \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Combinator.$O
-$(OBJDIR)/Text/ParserCombinators/Parsec/Language.$O: \
- $(OBJDIR)/Text/ParserCombinators/Parsec.$O \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Token.$O
-$(OBJDIR)/Text/ParserCombinators/Parsec/Perm.$O: \
- $(OBJDIR)/Text/ParserCombinators/Parsec.$O
-$(OBJDIR)/Text/ParserCombinators/Parsec/Prim.$O: \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Pos.$O \
- $(OBJDIR)/Text/ParserCombinators/Parsec/Error.$O
-$(OBJDIR)/Text/ParserCombinators/Parsec/Token.$O: \
- $(OBJDIR)/Text/ParserCombinators/Parsec.$O
# C-files dependencies.
Data/FiniteMap.$C: Data/Maybe.$C
Foreign/Marshal/Error.$C: Foreign/Ptr.$C
Foreign/C/String.$C: Data/Word.$C Foreign/Ptr.$C Foreign/C/Types.$C \
Foreign/Marshal/Array.$C
-Text/ParserCombinators/Parsec/Char.$C: \
- Text/ParserCombinators/Parsec/Pos.$C \
- Text/ParserCombinators/Parsec/Prim.$C
-Text/ParserCombinators/Parsec/Combinator.$C: \
- Text/ParserCombinators/Parsec/Prim.$C
-Text/ParserCombinators/Parsec/Error.$C: \
- Text/ParserCombinators/Parsec/Pos.$C
-Text/ParserCombinators/Parsec/Expr.$C: \
- Text/ParserCombinators/Parsec/Prim.$C \
- Text/ParserCombinators/Parsec/Combinator.$C
-Text/ParserCombinators/Parsec/Language.$C: \
- Text/ParserCombinators/Parsec.$C \
- Text/ParserCombinators/Parsec/Token.$C
-Text/ParserCombinators/Parsec/Perm.$C: \
- Text/ParserCombinators/Parsec.$C
-Text/ParserCombinators/Parsec/Prim.$C: \
- Text/ParserCombinators/Parsec/Pos.$C \
- Text/ParserCombinators/Parsec/Error.$C
-Text/ParserCombinators/Parsec/Token.$C: \
- Text/ParserCombinators/Parsec.$C
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Text.ParserCombinators.Parsec
--- Copyright : (c) Daan Leijen 1999-2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : daan@cs.uu.nl
--- Stability : provisional
--- Portability : portable
---
--- Parsec, the Fast Monadic Parser combinator library, see
--- <http://www.cs.uu.nl/people/daan/parsec.html>.
---
--- Inspired by:
---
--- * Graham Hutton and Erik Meijer:
--- Monadic Parser Combinators.
--- Technical report NOTTCS-TR-96-4.
--- Department of Computer Science, University of Nottingham, 1996.
--- <http://www.cs.nott.ac.uk/~gmh/monparsing.ps>
---
--- * Andrew Partridge, David Wright:
--- Predictive parser combinators need four values to report errors.
--- Journal of Functional Programming 6(2): 355-364, 1996
---
--- This helper module exports elements from the basic libraries.
---
------------------------------------------------------------------------------
-
-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
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Text.ParserCombinators.Parsec.Char
--- Copyright : (c) Daan Leijen 1999-2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : daan@cs.uu.nl
--- Stability : provisional
--- Portability : portable
---
--- Commonly used character parsers.
---
------------------------------------------------------------------------------
-
-module Text.ParserCombinators.Parsec.Char
- ( CharParser
- , spaces, space
- , newline, tab
- , upper, lower, alphaNum, letter
- , digit, hexDigit, octDigit
- , char, string
- , anyChar, oneOf, noneOf
- , satisfy
- ) where
-
-import Prelude
-import Data.Char
-import Text.ParserCombinators.Parsec.Pos( updatePosChar, updatePosString )
-import Text.ParserCombinators.Parsec.Prim
-
------------------------------------------------------------
--- Type of character parsers
------------------------------------------------------------
-type CharParser st a = GenParser Char st a
-
------------------------------------------------------------
--- Character parsers
------------------------------------------------------------
-oneOf cs = satisfy (\c -> elem c cs)
-noneOf cs = satisfy (\c -> not (elem c cs))
-
-spaces = skipMany space <?> "white space"
-space = satisfy (isSpace) <?> "space"
-
-newline = char '\n' <?> "new-line"
-tab = char '\t' <?> "tab"
-
-upper = satisfy (isUpper) <?> "uppercase letter"
-lower = satisfy (isLower) <?> "lowercase letter"
-alphaNum = satisfy (isAlphaNum) <?> "letter or digit"
-letter = satisfy (isAlpha) <?> "letter"
-digit = satisfy (isDigit) <?> "digit"
-hexDigit = satisfy (isHexDigit) <?> "hexadecimal digit"
-octDigit = satisfy (isOctDigit) <?> "octal digit"
-
-char c = satisfy (==c) <?> show [c]
-anyChar = satisfy (const True)
-
------------------------------------------------------------
--- Primitive character parsers
------------------------------------------------------------
-satisfy :: (Char -> Bool) -> CharParser st Char
-satisfy f = tokenPrim (\c -> show [c])
- (\pos c cs -> updatePosChar pos c)
- (\c -> if f c then Just c else Nothing)
-
-string :: String -> CharParser st String
-string s = tokens show updatePosString s
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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
- }
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Text.ParserCombinators.Parsec.Error
--- Copyright : (c) Daan Leijen 1999-2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : daan@cs.uu.nl
--- Stability : provisional
--- Portability : portable
---
--- Parse errors
---
------------------------------------------------------------------------------
-
-module Text.ParserCombinators.Parsec.Error
- ( Message(SysUnExpect,UnExpect,Expect,Message)
- , messageString, messageCompare, messageEq
-
- , ParseError, errorPos, errorMessages, errorIsUnknown
- , showErrorMessages
-
- , newErrorMessage, newErrorUnknown
- , addErrorMessage, setErrorPos, setErrorMessage
- , mergeError
- )
- where
-
-
-import Prelude
-import Data.List (nub,sortBy)
-import Text.ParserCombinators.Parsec.Pos
-
------------------------------------------------------------
--- Messages
------------------------------------------------------------
-data Message = SysUnExpect !String --library generated unexpect
- | UnExpect !String --unexpected something
- | Expect !String --expecting something
- | Message !String --raw message
-
-messageToEnum msg
- = case msg of SysUnExpect _ -> 0
- UnExpect _ -> 1
- Expect _ -> 2
- Message _ -> 3
-
-messageCompare :: Message -> Message -> Ordering
-messageCompare msg1 msg2
- = compare (messageToEnum msg1) (messageToEnum msg2)
-
-messageString :: Message -> String
-messageString msg
- = case msg of SysUnExpect s -> s
- UnExpect s -> s
- Expect s -> s
- Message s -> s
-
-messageEq :: Message -> Message -> Bool
-messageEq msg1 msg2
- = (messageCompare msg1 msg2 == EQ)
-
-
------------------------------------------------------------
--- Parse Errors
------------------------------------------------------------
-data ParseError = ParseError !SourcePos [Message]
-
-errorPos :: ParseError -> SourcePos
-errorPos (ParseError pos msgs)
- = pos
-
-errorMessages :: ParseError -> [Message]
-errorMessages (ParseError pos msgs)
- = sortBy messageCompare msgs
-
-errorIsUnknown :: ParseError -> Bool
-errorIsUnknown (ParseError pos msgs)
- = null msgs
-
-
------------------------------------------------------------
--- Create parse errors
------------------------------------------------------------
-newErrorUnknown :: SourcePos -> ParseError
-newErrorUnknown pos
- = ParseError pos []
-
-newErrorMessage :: Message -> SourcePos -> ParseError
-newErrorMessage msg pos
- = ParseError pos [msg]
-
-addErrorMessage :: Message -> ParseError -> ParseError
-addErrorMessage msg (ParseError pos msgs)
- = ParseError pos (msg:msgs)
-
-setErrorPos :: SourcePos -> ParseError -> ParseError
-setErrorPos pos (ParseError _ msgs)
- = ParseError pos msgs
-
-setErrorMessage :: Message -> ParseError -> ParseError
-setErrorMessage msg (ParseError pos msgs)
- = ParseError pos (msg:filter (not . messageEq msg) msgs)
-
-
-mergeError :: ParseError -> ParseError -> ParseError
-mergeError (ParseError pos msgs1) (ParseError _ msgs2)
- = ParseError pos (msgs1 ++ msgs2)
-
-
-
------------------------------------------------------------
--- Show Parse Errors
------------------------------------------------------------
-instance Show ParseError where
- show err
- = show (errorPos err) ++ ":" ++
- showErrorMessages "or" "unknown parse error"
- "expecting" "unexpected" "end of input"
- (errorMessages err)
-
-
--- Language independent show function
-showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
- | null msgs = msgUnknown
- | otherwise = concat $ map ("\n"++) $ clean $
- [showSysUnExpect,showUnExpect,showExpect,showMessages]
- where
- (sysUnExpect,msgs1) = span (messageEq (SysUnExpect "")) msgs
- (unExpect,msgs2) = span (messageEq (UnExpect "")) msgs1
- (expect,messages) = span (messageEq (Expect "")) msgs2
-
- showExpect = showMany msgExpecting expect
- showUnExpect = showMany msgUnExpected unExpect
- showSysUnExpect | not (null unExpect) ||
- null sysUnExpect = ""
- | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput
- | otherwise = msgUnExpected ++ " " ++ firstMsg
- where
- firstMsg = messageString (head sysUnExpect)
-
- showMessages = showMany "" messages
-
-
- --helpers
- showMany pre msgs = case (clean (map messageString msgs)) of
- [] -> ""
- ms | null pre -> commasOr ms
- | otherwise -> pre ++ " " ++ commasOr ms
-
- commasOr [] = ""
- commasOr [m] = m
- commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
-
- commaSep = seperate ", " . clean
- semiSep = seperate "; " . clean
-
- seperate sep [] = ""
- seperate sep [m] = m
- seperate sep (m:ms) = m ++ sep ++ seperate sep ms
-
- clean = nub . filter (not.null)
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Text.ParserCombinators.Parsec.Expr
--- Copyright : (c) Daan Leijen 1999-2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : daan@cs.uu.nl
--- Stability : provisional
--- Portability : portable
---
--- A helper module to parse \"expressions\".
--- Builds a parser given a table of operators and associativities.
---
------------------------------------------------------------------------------
-
-module Text.ParserCombinators.Parsec.Expr
- ( Assoc(..), Operator(..), OperatorTable
- , buildExpressionParser
- ) where
-
-import Text.ParserCombinators.Parsec.Prim
-import Text.ParserCombinators.Parsec.Combinator
-
-
------------------------------------------------------------
--- Assoc and OperatorTable
------------------------------------------------------------
-data Assoc = AssocNone
- | AssocLeft
- | AssocRight
-
-data Operator t st a = Infix (GenParser t st (a -> a -> a)) Assoc
- | Prefix (GenParser t st (a -> a))
- | Postfix (GenParser t st (a -> a))
-
-type OperatorTable t st a = [[Operator t st a]]
-
-
-
------------------------------------------------------------
--- Convert an OperatorTable and basic term parser into
--- a full fledged expression parser
------------------------------------------------------------
-buildExpressionParser :: OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a
-buildExpressionParser operators simpleExpr
- = foldl (makeParser) simpleExpr operators
- where
- makeParser term ops
- = let (rassoc,lassoc,nassoc
- ,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops
-
- rassocOp = choice rassoc
- lassocOp = choice lassoc
- nassocOp = choice nassoc
- prefixOp = choice prefix <?> ""
- postfixOp = choice postfix <?> ""
-
- ambigious assoc op= try $
- do{ op; fail ("ambiguous use of a " ++ assoc
- ++ " associative operator")
- }
-
- ambigiousRight = ambigious "right" rassocOp
- ambigiousLeft = ambigious "left" lassocOp
- ambigiousNon = ambigious "non" nassocOp
-
- termP = do{ pre <- prefixP
- ; x <- term
- ; post <- postfixP
- ; return (post (pre x))
- }
-
- postfixP = postfixOp <|> return id
-
- prefixP = prefixOp <|> return id
-
- rassocP x = do{ f <- rassocOp
- ; y <- do{ z <- termP; rassocP1 z }
- ; return (f x y)
- }
- <|> ambigiousLeft
- <|> ambigiousNon
- -- <|> return x
-
- rassocP1 x = rassocP x <|> return x
-
- lassocP x = do{ f <- lassocOp
- ; y <- termP
- ; lassocP1 (f x y)
- }
- <|> ambigiousRight
- <|> ambigiousNon
- -- <|> return x
-
- lassocP1 x = lassocP x <|> return x
-
- nassocP x = do{ f <- nassocOp
- ; y <- termP
- ; ambigiousRight
- <|> ambigiousLeft
- <|> ambigiousNon
- <|> return (f x y)
- }
- -- <|> return x
-
- in do{ x <- termP
- ; rassocP x <|> lassocP x <|> nassocP x <|> return x
- <?> "operator"
- }
-
-
- splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix)
- = case assoc of
- AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix)
- AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix)
- AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix)
-
- splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix)
- = (rassoc,lassoc,nassoc,op:prefix,postfix)
-
- splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix)
- = (rassoc,lassoc,nassoc,prefix,op:postfix)
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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
- }
-
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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 ++
- ")"
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Text.ParserCombinators.Parsec.Prim
--- Copyright : (c) Daan Leijen 1999-2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : daan@cs.uu.nl
--- Stability : provisional
--- Portability : portable
---
--- The primitive parser combinators.
---
------------------------------------------------------------------------------
-
-module Text.ParserCombinators.Parsec.Prim
- ( -- operators: label a parser, alternative
- (<?>), (<|>)
-
- -- basic types
- , Parser, GenParser
- , runParser, parse, parseFromFile, parseTest
-
- -- primitive parsers:
- -- instance Functor Parser : fmap
- -- instance Monad Parser : return, >>=, fail
- -- instance MonadPlus Parser : mzero (pzero), mplus (<|>)
- , token, tokens, tokenPrim
- , try, label, labels, unexpected, pzero
-
- -- primitive because of space behaviour
- , many, skipMany
-
- -- user state manipulation
- , getState, setState, updateState
-
- -- state manipulation
- , getPosition, setPosition
- , getInput, setInput
- , getParserState, setParserState
- ) where
-
-import Prelude
-import Text.ParserCombinators.Parsec.Pos
-import Text.ParserCombinators.Parsec.Error
-import Control.Monad
-
-{-# INLINE parsecMap #-}
-{-# INLINE parsecReturn #-}
-{-# INLINE parsecBind #-}
-{-# INLINE parsecZero #-}
-{-# INLINE parsecPlus #-}
-{-# INLINE token #-}
-{-# INLINE tokenPrim #-}
-
------------------------------------------------------------
--- Operators:
--- <?> gives a name to a parser (which is used in error messages)
--- <|> is the choice operator
------------------------------------------------------------
-infix 0 <?>
-infixr 1 <|>
-
-(<?>) :: GenParser tok st a -> String -> GenParser tok st a
-p <?> msg = label p msg
-
-(<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
-p1 <|> p2 = mplus p1 p2
-
-
------------------------------------------------------------
--- User state combinators
------------------------------------------------------------
-getState :: GenParser tok st st
-getState = do{ state <- getParserState
- ; return (stateUser state)
- }
-
-setState :: st -> GenParser tok st ()
-setState st = do{ updateParserState (\(State input pos _) -> State input pos st)
- ; return ()
- }
-
-updateState :: (st -> st) -> GenParser tok st ()
-updateState f = do{ updateParserState (\(State input pos user) -> State input pos (f user))
- ; return ()
- }
-
-
------------------------------------------------------------
--- Parser state combinators
------------------------------------------------------------
-getPosition :: GenParser tok st SourcePos
-getPosition = do{ state <- getParserState; return (statePos state) }
-
-getInput :: GenParser tok st [tok]
-getInput = do{ state <- getParserState; return (stateInput state) }
-
-
-setPosition :: SourcePos -> GenParser tok st ()
-setPosition pos = do{ updateParserState (\(State input _ user) -> State input pos user)
- ; return ()
- }
-
-setInput :: [tok] -> GenParser tok st ()
-setInput input = do{ updateParserState (\(State _ pos user) -> State input pos user)
- ; return ()
- }
-
-getParserState :: GenParser tok st (State tok st)
-getParserState = updateParserState id
-
-setParserState :: State tok st -> GenParser tok st (State tok st)
-setParserState st = updateParserState (const st)
-
-
-
-
------------------------------------------------------------
--- Parser definition.
--- GenParser tok st a:
--- General parser for tokens of type "tok",
--- a user state "st" and a result type "a"
------------------------------------------------------------
-type Parser a = GenParser Char () a
-
-newtype GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a))
-runP (Parser p) = p
-
-data Consumed a = Consumed a --input is consumed
- | Empty !a --no input is consumed
-
-data Reply tok st a = Ok a (State tok st) ParseError --parsing succeeded with "a"
- | Error ParseError --parsing failed
-
-data State tok st = State { stateInput :: [tok]
- , statePos :: SourcePos
- , stateUser :: !st
- }
-
-
------------------------------------------------------------
--- run a parser
------------------------------------------------------------
-parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)
-parseFromFile p fname
- = do{ input <- readFile fname
- ; return (parse p fname input)
- }
-
-parseTest :: Show a => GenParser tok () a -> [tok] -> IO ()
-parseTest p input
- = case (runParser p () "" input) of
- Left err -> do{ putStr "parse error at "
- ; print err
- }
- Right x -> print x
-
-
-parse :: GenParser tok () a -> SourceName -> [tok] -> Either ParseError a
-parse p name input
- = runParser p () name input
-
-
-runParser :: GenParser tok st a -> st -> SourceName -> [tok] -> Either ParseError a
-runParser p st name input
- = case parserReply (runP p (State input (initialPos name) st)) of
- Ok x _ _ -> Right x
- Error err -> Left err
-
-parserReply result
- = case result of
- Consumed reply -> reply
- Empty reply -> reply
-
-
------------------------------------------------------------
--- Functor: fmap
------------------------------------------------------------
-instance Functor (GenParser tok st) where
- fmap f p = parsecMap f p
-
-parsecMap :: (a -> b) -> GenParser tok st a -> GenParser tok st b
-parsecMap f (Parser p)
- = Parser (\state ->
- case (p state) of
- Consumed reply -> Consumed (mapReply reply)
- Empty reply -> Empty (mapReply reply)
- )
- where
- mapReply reply
- = case reply of
- Ok x state err -> let fx = f x
- in seq fx (Ok fx state err)
- Error err -> Error err
-
-
------------------------------------------------------------
--- Monad: return, sequence (>>=) and fail
------------------------------------------------------------
-instance Monad (GenParser tok st) where
- return x = parsecReturn x
- p >>= f = parsecBind p f
- fail msg = parsecFail msg
-
-parsecReturn :: a -> GenParser tok st a
-parsecReturn x
- = Parser (\state -> Empty (Ok x state (unknownError state)))
-
-parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b
-parsecBind (Parser p) f
- = Parser (\state ->
- case (p state) of
- Consumed reply1
- -> Consumed $
- case (reply1) of
- Ok x state1 err1 -> case runP (f x) state1 of
- Empty reply2 -> mergeErrorReply err1 reply2
- Consumed reply2 -> reply2
- Error err1 -> Error err1
-
- Empty reply1
- -> case (reply1) of
- Ok x state1 err1 -> case runP (f x) state1 of
- Empty reply2 -> Empty (mergeErrorReply err1 reply2)
- other -> other
- Error err1 -> Empty (Error err1)
- )
-
-mergeErrorReply err1 reply
- = case reply of
- Ok x state err2 -> Ok x state (mergeError err1 err2)
- Error err2 -> Error (mergeError err1 err2)
-
-
-parsecFail :: String -> GenParser tok st a
-parsecFail msg
- = Parser (\state ->
- Empty (Error (newErrorMessage (Message msg) (statePos state))))
-
-
------------------------------------------------------------
--- MonadPlus: alternative (mplus) and mzero
------------------------------------------------------------
-instance MonadPlus (GenParser tok st) where
- mzero = parsecZero
- mplus p1 p2 = parsecPlus p1 p2
-
-
-pzero :: GenParser tok st a
-pzero = parsecZero
-
-parsecZero :: GenParser tok st a
-parsecZero
- = Parser (\state -> Empty (Error (unknownError state)))
-
-parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
-parsecPlus (Parser p1) (Parser p2)
- = Parser (\state ->
- case (p1 state) of
- Empty (Error err) -> case (p2 state) of
- Empty reply -> Empty (mergeErrorReply err reply)
- consumed -> consumed
- other -> other
- )
-
-
-{-
--- variant that favors a consumed reply over an empty one, even it is not the first alternative.
- empty@(Empty reply) -> case reply of
- Error err ->
- case (p2 state) of
- Empty reply -> Empty (mergeErrorReply err reply)
- consumed -> consumed
- ok ->
- case (p2 state) of
- Empty reply -> empty
- consumed -> consumed
- consumed -> consumed
--}
-
-
------------------------------------------------------------
--- Primitive Parsers:
--- try, token(Prim), label, unexpected and updateState
------------------------------------------------------------
-try :: GenParser tok st a -> GenParser tok st a
-try (Parser p)
- = Parser (\state@(State input pos user) ->
- case (p state) of
- Consumed (Error err) -> Empty (Error (setErrorPos pos err))
- Consumed ok -> Consumed ok -- was: Empty ok
- empty -> empty
- )
-
-
-token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
-token show tokpos test
- = tokenPrim show nextpos test
- where
- nextpos _ _ (tok:toks) = tokpos tok
- nextpos _ tok [] = tokpos tok
-
-tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
-tokenPrim show nextpos test
- = Parser (\state@(State input pos user) ->
- case input of
- (c:cs) -> case test c of
- Just x -> let newpos = nextpos pos c cs
- newstate = State cs newpos user
- in seq newpos $ seq newstate $
- Consumed (Ok x newstate (newErrorUnknown newpos))
- Nothing -> Empty (sysUnExpectError (show c) pos)
- [] -> Empty (sysUnExpectError "" pos)
- )
-
-
-label :: GenParser tok st a -> String -> GenParser tok st a
-label p msg
- = labels p [msg]
-
-labels :: GenParser tok st a -> [String] -> GenParser tok st a
-labels (Parser p) msgs
- = Parser (\state ->
- case (p state) of
- Empty reply -> Empty $
- case (reply) of
- Error err -> Error (setExpectErrors err msgs)
- Ok x state1 err | errorIsUnknown err -> reply
- | otherwise -> Ok x state1 (setExpectErrors err msgs)
- other -> other
- )
-
-
-updateParserState :: (State tok st -> State tok st) -> GenParser tok st (State tok st)
-updateParserState f
- = Parser (\state -> let newstate = f state
- in seq newstate $
- Empty (Ok state newstate (unknownError newstate)))
-
-
-unexpected :: String -> GenParser tok st a
-unexpected msg
- = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state))))
-
-
-setExpectErrors err [] = setErrorMessage (Expect "") err
-setExpectErrors err [msg] = setErrorMessage (Expect msg) err
-setExpectErrors err (msg:msgs) = foldr (\msg err -> addErrorMessage (Expect msg) err)
- (setErrorMessage (Expect msg) err) msgs
-
-sysUnExpectError msg pos = Error (newErrorMessage (SysUnExpect msg) pos)
-unknownError state = newErrorUnknown (statePos state)
-
------------------------------------------------------------
--- Parsers unfolded for space:
--- if many and skipMany are not defined as primitives,
--- they will overflow the stack on large inputs
------------------------------------------------------------
-many :: GenParser tok st a -> GenParser tok st [a]
-many p
- = do{ xs <- manyAccum (:) p
- ; return (reverse xs)
- }
-
-skipMany :: GenParser tok st a -> GenParser tok st ()
-skipMany p
- = do{ manyAccum (\x xs -> []) p
- ; return ()
- }
-
-manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a]
-manyAccum accum (Parser p)
- = Parser (\state ->
- let walk xs state r = case r of
- Empty (Error err) -> Ok xs state err
- Empty ok -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
- Consumed (Error err) -> Error err
- Consumed (Ok x state' err) -> let ys = accum x xs
- in seq ys (walk ys state' (p state'))
- in case (p state) of
- Empty reply -> case reply of
- Ok x state' err -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
- Error err -> Empty (Ok [] state err)
- consumed -> Consumed $ walk [] state consumed)
-
-
-
------------------------------------------------------------
--- Parsers unfolded for speed:
--- tokens
------------------------------------------------------------
-
-{- specification of @tokens@:
-tokens showss nextposs s
- = scan s
- where
- scan [] = return s
- scan (c:cs) = do{ token show nextpos c <?> shows s; scan cs }
-
- show c = shows [c]
- nextpos pos c = nextposs pos [c]
--}
-
-tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok]
-tokens shows nextposs s
- = Parser (\state@(State input pos user) ->
- let
- ok cs = let newpos = nextposs pos s
- newstate = State cs newpos user
- in seq newpos $ seq newstate $
- (Ok s newstate (newErrorUnknown newpos))
-
- errEof = Error (setErrorMessage (Expect (shows s))
- (newErrorMessage (SysUnExpect "") pos))
- errExpect c = Error (setErrorMessage (Expect (shows s))
- (newErrorMessage (SysUnExpect (shows [c])) pos))
-
- walk [] cs = ok cs
- walk xs [] = errEof
- walk (x:xs) (c:cs)| x == c = walk xs cs
- | otherwise = errExpect c
-
- walk1 [] cs = Empty (ok cs)
- walk1 xs [] = Empty (errEof)
- walk1 (x:xs) (c:cs)| x == c = Consumed (walk xs cs)
- | otherwise = Empty (errExpect c)
-
- in walk1 s input)
-
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- 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)
-
+++ /dev/null
-----------------------------------------------------------------
--- 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
+++ /dev/null
-----------------------------------------------------------------
--- 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"
- ]
- }
+++ /dev/null
-----------------------------------------------------------------
--- 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"
-
-
+++ /dev/null
--- 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:*}
- }
-
-
-
-
+++ /dev/null
------------------------------------------------------------
--- Daan Leijen (c) 1999-2000, daan@cs.uu.nl
------------------------------------------------------------
-module Main where
-
-import MonParser (prettyFile)
-
-
-main :: IO ()
-main = prettyFile "prelude.m"
+++ /dev/null
------------------------------------------------------------
--- 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
+++ /dev/null
-{-
-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]
+++ /dev/null
-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
+++ /dev/null
-{-
-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\r ; d:ds -> (vertical ((o <|> d):[s <|> d | d <- ds ])) <-> c
- }
-
--- Helper function
-
-indent :: Int -> ShowS
-indent = \n ->
- showString [ ' ' | i <- [1..n] ]
+++ /dev/null
-{-
-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
+++ /dev/null
-{-
-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 ]
- }
+++ /dev/null
-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}
-}
+++ /dev/null
------------------------------------------------------------
--- 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
-
-
+++ /dev/null
-{---------------------------------------------------------------
-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"
+++ /dev/null
--------------------------------------------------------------
--- 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
+++ /dev/null
-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)
+++ /dev/null
-let function fact(n : int) : int =
- if n < 1 then 1 else (n * fact(n - 1))
- in fact(10)
-end
+++ /dev/null
-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
+++ /dev/null
-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
-
+++ /dev/null
-/* 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
-
+++ /dev/null
-{---------------------------------------------------------------
-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"
+++ /dev/null
--------------------------------------------------------------
--- 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
+++ /dev/null
-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)
+++ /dev/null
-y := x; z := 1; while y>1 do (z := z*y; y:=y-1); y:=0
-
+++ /dev/null
-v := 1;
-u := 1;
-if n <= 2 then
- skip
-else
- while n > 2 do (
- t := u;
- u := v;
- v := u + t
- )
-
projects / ghc-base.git / commitdiff