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.
-----------------------------------------------------------------------------
be a definition of the Haskell 98 Foreign Function Interface.
-----------------------------------------------------------------------------
+
+Code derived from Daan Leijen's Parsec is distributed under the following
+license:
+
+ Copyright 1999-2000, Daan Leijen. All rights reserved.
+
+ Redistribution and use in source and binary forms, with or without
+ modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+This software is provided by the copyright holders "as is" and any express or
+implied warranties, including, but not limited to, the implied warranties of
+merchantability and fitness for a particular purpose are disclaimed. In no
+event shall the copyright holders be liable for any direct, indirect,
+incidental, special, exemplary, or consequential damages (including, but not
+limited to, procurement of substitute goods or services; loss of use, data,
+or profits; or business interruption) however caused and on any theory of
+liability, whether in contract, strict liability, or tort (including
+negligence or otherwise) arising in any way out of the use of this software,
+even if advised of the possibility of such damage.
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.28 2002/05/27 14:30:49 simonmar Exp $
+# $Id: Makefile,v 1.29 2002/05/31 12:22:33 panne Exp $
TOP=..
include $(TOP)/mk/boilerplate.mk
Text/Html \
Text/PrettyPrint \
Text/ParserCombinators \
+ Text/ParserCombinators/Parsec \
Text/Regex \
Text/Show \
Text/Read
--- /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.
+-- <http://www.cs.uu.nl/people/daan/parsec.html>
+--
+-- This helper module exports elements from the basic libraries.
+-- Inspired by:
+--
+-- * Graham Hutton and Erik Meijer:
+-- Monadic Parser Combinators.
+-- Technical report NOTTCS-TR-96-4.
+-- Department of Computer Science, University of Nottingham, 1996.
+-- <http://www.cs.nott.ac.uk/Department/Staff/gmh/monparsing.ps>
+--
+-- * Andrew Partridge, David Wright:
+-- Predictive parser combinators need four values to report errors.
+-- Journal of Functional Programming 6(2): 355-364, 1996
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec
+ ( -- complete modules
+ module Text.ParserCombinators.Parsec.Prim
+ , module Text.ParserCombinators.Parsec.Combinator
+ , module Text.ParserCombinators.Parsec.Char
+
+ -- module Text.ParserCombinators.Parsec.Error
+ , ParseError
+ , errorPos
+
+ -- module Text.ParserCombinators.Parsec.Pos
+ , SourcePos
+ , SourceName, Line, Column
+ , sourceName, sourceLine, sourceColumn
+ , incSourceLine, incSourceColumn
+ , setSourceLine, setSourceColumn, setSourceName
+
+ ) where
+
+import Text.ParserCombinators.Parsec.Pos -- textual positions
+import Text.ParserCombinators.Parsec.Error -- parse errors
+import Text.ParserCombinators.Parsec.Prim -- primitive combinators
+import Text.ParserCombinators.Parsec.Combinator -- derived combinators
+import Text.ParserCombinators.Parsec.Char -- character parsers
+
--- /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 Data.Char
+import Text.ParserCombinators.Parsec.Pos( updatePosChar, updatePosString )
+import Text.ParserCombinators.Parsec.Prim
+
+-----------------------------------------------------------
+-- Type of character parsers
+-----------------------------------------------------------
+type CharParser st a = GenParser Char st a
+
+-----------------------------------------------------------
+-- Character parsers
+-----------------------------------------------------------
+oneOf cs = satisfy (\c -> elem c cs)
+noneOf cs = satisfy (\c -> not (elem c cs))
+
+spaces = skipMany space <?> "white space"
+space = satisfy (isSpace) <?> "space"
+
+newline = char '\n' <?> "new-line"
+tab = char '\t' <?> "tab"
+
+upper = satisfy (isUpper) <?> "uppercase letter"
+lower = satisfy (isLower) <?> "lowercase letter"
+alphaNum = satisfy (isAlphaNum) <?> "letter or digit"
+letter = satisfy (isAlpha) <?> "letter"
+digit = satisfy (isDigit) <?> "digit"
+hexDigit = satisfy (isHexDigit) <?> "hexadecimal digit"
+octDigit = satisfy (isOctDigit) <?> "octal digit"
+
+char c = satisfy (==c) <?> show [c]
+anyChar = satisfy (const True)
+
+-----------------------------------------------------------
+-- Primitive character parsers
+-----------------------------------------------------------
+satisfy :: (Char -> Bool) -> CharParser st Char
+satisfy f = tokenPrim (\c -> show [c])
+ (\pos c cs -> updatePosChar pos c)
+ (\c -> if f c then Just c else Nothing)
+
+string :: String -> CharParser st String
+string s = tokens show updatePosString s
\ No newline at end of file
--- /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 Data.List (nub,sortBy)
+import Text.ParserCombinators.Parsec.Pos
+
+-----------------------------------------------------------
+-- Messages
+-----------------------------------------------------------
+data Message = SysUnExpect !String --library generated unexpect
+ | UnExpect !String --unexpected something
+ | Expect !String --expecting something
+ | Message !String --raw message
+
+messageToEnum msg
+ = case msg of SysUnExpect _ -> 0
+ UnExpect _ -> 1
+ Expect _ -> 2
+ Message _ -> 3
+
+messageCompare msg1 msg2
+ = compare (messageToEnum msg1) (messageToEnum msg2)
+
+messageString msg
+ = case msg of SysUnExpect s -> s
+ UnExpect s -> s
+ Expect s -> s
+ Message s -> s
+
+messageEq msg1 msg2
+ = (messageCompare msg1 msg2 == EQ)
+
+
+-----------------------------------------------------------
+-- Parse Errors
+-----------------------------------------------------------
+data ParseError = ParseError !SourcePos [Message]
+
+errorPos :: ParseError -> SourcePos
+errorPos (ParseError pos msgs)
+ = pos
+
+errorMessages :: ParseError -> [Message]
+errorMessages (ParseError pos msgs)
+ = sortBy messageCompare msgs
+
+errorIsUnknown :: ParseError -> Bool
+errorIsUnknown (ParseError pos msgs)
+ = null msgs
+
+
+-----------------------------------------------------------
+-- Create parse errors
+-----------------------------------------------------------
+newErrorUnknown pos
+ = ParseError pos []
+
+newErrorMessage msg pos
+ = ParseError pos [msg]
+
+addErrorMessage msg (ParseError pos msgs)
+ = ParseError pos (msg:msgs)
+
+setErrorPos pos (ParseError _ msgs)
+ = ParseError pos msgs
+
+setErrorMessage msg (ParseError pos msgs)
+ = ParseError pos (msg:filter (not . messageEq msg) msgs)
+
+
+mergeError :: ParseError -> ParseError -> ParseError
+mergeError (ParseError pos msgs1) (ParseError _ msgs2)
+ = ParseError pos (msgs1 ++ msgs2)
+
+
+
+-----------------------------------------------------------
+-- Show Parse Errors
+-----------------------------------------------------------
+instance Show ParseError where
+ show err
+ = show (errorPos err) ++ ":" ++
+ showErrorMessages "or" "unknown parse error"
+ "expecting" "unexpected" "end of input"
+ (errorMessages err)
+
+
+-- Language independent show function
+showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
+ | null msgs = msgUnknown
+ | otherwise = concat $ map ("\n"++) $ clean $
+ [showSysUnExpect,showUnExpect,showExpect,showMessages]
+ where
+ (sysUnExpect,msgs1) = span (messageEq (SysUnExpect "")) msgs
+ (unExpect,msgs2) = span (messageEq (UnExpect "")) msgs1
+ (expect,messages) = span (messageEq (Expect "")) msgs2
+
+ showExpect = showMany msgExpecting expect
+ showUnExpect = showMany msgUnExpected unExpect
+ showSysUnExpect | not (null unExpect) ||
+ null sysUnExpect = ""
+ | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput
+ | otherwise = msgUnExpected ++ " " ++ firstMsg
+ where
+ firstMsg = messageString (head sysUnExpect)
+
+ showMessages = showMany "" messages
+
+
+ --helpers
+ showMany pre msgs = case (clean (map messageString msgs)) of
+ [] -> ""
+ ms | null pre -> commasOr ms
+ | otherwise -> pre ++ " " ++ commasOr ms
+
+ commasOr [] = ""
+ commasOr [m] = m
+ commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
+
+ commaSep = seperate ", " . clean
+ semiSep = seperate "; " . clean
+
+ seperate sep [] = ""
+ seperate sep [m] = m
+ seperate sep (m:ms) = m ++ sep ++ seperate sep ms
+
+ clean = nub . filter (not.null)
+
--- /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 Text.ParserCombinators.Parsec.Pos
+import Text.ParserCombinators.Parsec.Error
+import Control.Monad
+
+{-# INLINE parsecMap #-}
+{-# INLINE parsecReturn #-}
+{-# INLINE parsecBind #-}
+{-# INLINE parsecZero #-}
+{-# INLINE parsecPlus #-}
+{-# INLINE token #-}
+{-# INLINE tokenPrim #-}
+
+-----------------------------------------------------------
+-- Operators:
+-- <?> gives a name to a parser (which is used in error messages)
+-- <|> is the choice operator
+-----------------------------------------------------------
+infix 0 <?>
+infixr 1 <|>
+
+(<?>) :: GenParser tok st a -> String -> GenParser tok st a
+p <?> msg = label p msg
+
+(<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
+p1 <|> p2 = mplus p1 p2
+
+
+-----------------------------------------------------------
+-- User state combinators
+-----------------------------------------------------------
+getState :: GenParser tok st st
+getState = do{ state <- getParserState
+ ; return (stateUser state)
+ }
+
+setState :: st -> GenParser tok st ()
+setState st = do{ updateParserState (\(State input pos _) -> State input pos st)
+ ; return ()
+ }
+
+updateState :: (st -> st) -> GenParser tok st ()
+updateState f = do{ updateParserState (\(State input pos user) -> State input pos (f user))
+ ; return ()
+ }
+
+
+-----------------------------------------------------------
+-- Parser state combinators
+-----------------------------------------------------------
+getPosition :: GenParser tok st SourcePos
+getPosition = do{ state <- getParserState; return (statePos state) }
+
+getInput :: GenParser tok st [tok]
+getInput = do{ state <- getParserState; return (stateInput state) }
+
+
+setPosition :: SourcePos -> GenParser tok st ()
+setPosition pos = do{ updateParserState (\(State input _ user) -> State input pos user)
+ ; return ()
+ }
+
+setInput :: [tok] -> GenParser tok st ()
+setInput input = do{ updateParserState (\(State _ pos user) -> State input pos user)
+ ; return ()
+ }
+
+getParserState = updateParserState id
+setParserState st = updateParserState (const st)
+
+
+
+
+-----------------------------------------------------------
+-- Parser definition.
+-- GenParser tok st a:
+-- General parser for tokens of type "tok",
+-- a user state "st" and a result type "a"
+-----------------------------------------------------------
+type Parser a = GenParser Char () a
+
+newtype GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a))
+runP (Parser p) = p
+
+data Consumed a = Consumed a --input is consumed
+ | Empty !a --no input is consumed
+
+data Reply tok st a = Ok a (State tok st) ParseError --parsing succeeded with "a"
+ | Error ParseError --parsing failed
+
+data State tok st = State { stateInput :: [tok]
+ , statePos :: SourcePos
+ , stateUser :: !st
+ }
+
+
+-----------------------------------------------------------
+-- run a parser
+-----------------------------------------------------------
+parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)
+parseFromFile p fname
+ = do{ input <- readFile fname
+ ; return (parse p fname input)
+ }
+
+parseTest :: Show a => GenParser tok () a -> [tok] -> IO ()
+parseTest p input
+ = case (runParser p () "" input) of
+ Left err -> do{ putStr "parse error at "
+ ; print err
+ }
+ Right x -> print x
+
+
+parse p name input
+ = runParser p () name input
+
+
+runParser :: GenParser tok st a -> st -> SourceName -> [tok] -> Either ParseError a
+runParser p st name input
+ = case parserReply (runP p (State input (initialPos name) st)) of
+ Ok x _ _ -> Right x
+ Error err -> Left err
+
+parserReply result
+ = case result of
+ Consumed reply -> reply
+ Empty reply -> reply
+
+
+-----------------------------------------------------------
+-- Functor: fmap
+-----------------------------------------------------------
+instance Functor (GenParser tok st) where
+ fmap f p = parsecMap f p
+
+parsecMap :: (a -> b) -> GenParser tok st a -> GenParser tok st b
+parsecMap f (Parser p)
+ = Parser (\state ->
+ case (p state) of
+ Consumed reply -> Consumed (mapReply reply)
+ Empty reply -> Empty (mapReply reply)
+ )
+ where
+ mapReply reply
+ = case reply of
+ Ok x state err -> let fx = f x
+ in seq fx (Ok fx state err)
+ Error err -> Error err
+
+
+-----------------------------------------------------------
+-- Monad: return, sequence (>>=) and fail
+-----------------------------------------------------------
+instance Monad (GenParser tok st) where
+ return x = parsecReturn x
+ p >>= f = parsecBind p f
+ fail msg = parsecFail msg
+
+parsecReturn :: a -> GenParser tok st a
+parsecReturn x
+ = Parser (\state -> Empty (Ok x state (unknownError state)))
+
+parsecBind :: GenParser tok st a -> (a -> GenParser tok st b) -> GenParser tok st b
+parsecBind (Parser p) f
+ = Parser (\state ->
+ case (p state) of
+ Consumed reply1
+ -> Consumed $
+ case (reply1) of
+ Ok x state1 err1 -> case runP (f x) state1 of
+ Empty reply2 -> mergeErrorReply err1 reply2
+ Consumed reply2 -> reply2
+ Error err1 -> Error err1
+
+ Empty reply1
+ -> case (reply1) of
+ Ok x state1 err1 -> case runP (f x) state1 of
+ Empty reply2 -> Empty (mergeErrorReply err1 reply2)
+ other -> other
+ Error err1 -> Empty (Error err1)
+ )
+
+mergeErrorReply err1 reply
+ = case reply of
+ Ok x state err2 -> Ok x state (mergeError err1 err2)
+ Error err2 -> Error (mergeError err1 err2)
+
+
+parsecFail :: String -> GenParser tok st a
+parsecFail msg
+ = Parser (\state ->
+ Empty (Error (newErrorMessage (Message msg) (statePos state))))
+
+
+-----------------------------------------------------------
+-- MonadPlus: alternative (mplus) and mzero
+-----------------------------------------------------------
+instance MonadPlus (GenParser tok st) where
+ mzero = parsecZero
+ mplus p1 p2 = parsecPlus p1 p2
+
+
+pzero :: GenParser tok st a
+pzero = parsecZero
+
+parsecZero :: GenParser tok st a
+parsecZero
+ = Parser (\state -> Empty (Error (unknownError state)))
+
+parsecPlus :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a
+parsecPlus (Parser p1) (Parser p2)
+ = Parser (\state ->
+ case (p1 state) of
+ Empty (Error err) -> case (p2 state) of
+ Empty reply -> Empty (mergeErrorReply err reply)
+ consumed -> consumed
+ other -> other
+ )
+
+
+{-
+-- variant that favors a consumed reply over an empty one, even it is not the first alternative.
+ empty@(Empty reply) -> case reply of
+ Error err ->
+ case (p2 state) of
+ Empty reply -> Empty (mergeErrorReply err reply)
+ consumed -> consumed
+ ok ->
+ case (p2 state) of
+ Empty reply -> empty
+ consumed -> consumed
+ consumed -> consumed
+-}
+
+
+-----------------------------------------------------------
+-- Primitive Parsers:
+-- try, token(Prim), label, unexpected and updateState
+-----------------------------------------------------------
+try :: GenParser tok st a -> GenParser tok st a
+try (Parser p)
+ = Parser (\state@(State input pos user) ->
+ case (p state) of
+ Consumed (Error err) -> Empty (Error (setErrorPos pos err))
+ Consumed ok -> Consumed ok -- was: Empty ok
+ empty -> empty
+ )
+
+
+token :: (tok -> String) -> (tok -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
+token show tokpos test
+ = tokenPrim show nextpos test
+ where
+ nextpos _ _ (tok:toks) = tokpos tok
+ nextpos _ tok [] = tokpos tok
+
+tokenPrim :: (tok -> String) -> (SourcePos -> tok -> [tok] -> SourcePos) -> (tok -> Maybe a) -> GenParser tok st a
+tokenPrim show nextpos test
+ = Parser (\state@(State input pos user) ->
+ case input of
+ (c:cs) -> case test c of
+ Just x -> let newpos = nextpos pos c cs
+ newstate = State cs newpos user
+ in seq newpos $ seq newstate $
+ Consumed (Ok x newstate (newErrorUnknown newpos))
+ Nothing -> Empty (sysUnExpectError (show c) pos)
+ [] -> Empty (sysUnExpectError "" pos)
+ )
+
+
+label :: GenParser tok st a -> String -> GenParser tok st a
+label p msg
+ = labels p [msg]
+
+labels (Parser p) msgs
+ = Parser (\state ->
+ case (p state) of
+ Empty reply -> Empty $
+ case (reply) of
+ Error err -> Error (setExpectErrors err msgs)
+ Ok x state1 err | errorIsUnknown err -> reply
+ | otherwise -> Ok x state1 (setExpectErrors err msgs)
+ other -> other
+ )
+
+
+updateParserState :: (State tok st -> State tok st) -> GenParser tok st (State tok st)
+updateParserState f
+ = Parser (\state -> let newstate = f state
+ in seq newstate $
+ Empty (Ok state newstate (unknownError newstate)))
+
+
+unexpected :: String -> GenParser tok st a
+unexpected msg
+ = Parser (\state -> Empty (Error (newErrorMessage (UnExpect msg) (statePos state))))
+
+
+setExpectErrors err [] = setErrorMessage (Expect "") err
+setExpectErrors err [msg] = setErrorMessage (Expect msg) err
+setExpectErrors err (msg:msgs) = foldr (\msg err -> addErrorMessage (Expect msg) err)
+ (setErrorMessage (Expect msg) err) msgs
+
+sysUnExpectError msg pos = Error (newErrorMessage (SysUnExpect msg) pos)
+unknownError state = newErrorUnknown (statePos state)
+
+-----------------------------------------------------------
+-- Parsers unfolded for space:
+-- if many and skipMany are not defined as primitives,
+-- they will overflow the stack on large inputs
+-----------------------------------------------------------
+many :: GenParser tok st a -> GenParser tok st [a]
+many p
+ = do{ xs <- manyAccum (:) p
+ ; return (reverse xs)
+ }
+
+skipMany :: GenParser tok st a -> GenParser tok st ()
+skipMany p
+ = do{ manyAccum (\x xs -> []) p
+ ; return ()
+ }
+
+manyAccum :: (a -> [a] -> [a]) -> GenParser tok st a -> GenParser tok st [a]
+manyAccum accum (Parser p)
+ = Parser (\state ->
+ let walk xs state r = case r of
+ Empty (Error err) -> Ok xs state err
+ Empty ok -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
+ Consumed (Error err) -> Error err
+ Consumed (Ok x state' err) -> let ys = accum x xs
+ in seq ys (walk ys state' (p state'))
+ in case (p state) of
+ Empty reply -> case reply of
+ Ok x state' err -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
+ Error err -> Empty (Ok [] state err)
+ consumed -> Consumed $ walk [] state consumed)
+
+
+
+-----------------------------------------------------------
+-- Parsers unfolded for speed:
+-- tokens
+-----------------------------------------------------------
+
+{- specification of @tokens@:
+tokens showss nextposs s
+ = scan s
+ where
+ scan [] = return s
+ scan (c:cs) = do{ token show nextpos c <?> shows s; scan cs }
+
+ show c = shows [c]
+ nextpos pos c = nextposs pos [c]
+-}
+
+tokens :: Eq tok => ([tok] -> String) -> (SourcePos -> [tok] -> SourcePos) -> [tok] -> GenParser tok st [tok]
+tokens shows nextposs s
+ = Parser (\state@(State input pos user) ->
+ let
+ ok cs = let newpos = nextposs pos s
+ newstate = State cs newpos user
+ in seq newpos $ seq newstate $
+ (Ok s newstate (newErrorUnknown newpos))
+
+ errEof = Error (setErrorMessage (Expect (shows s))
+ (newErrorMessage (SysUnExpect "") pos))
+ errExpect c = Error (setErrorMessage (Expect (shows s))
+ (newErrorMessage (SysUnExpect (shows [c])) pos))
+
+ walk [] cs = ok cs
+ walk xs [] = errEof
+ walk (x:xs) (c:cs)| x == c = walk xs cs
+ | otherwise = errExpect c
+
+ walk1 [] cs = Empty (ok cs)
+ walk1 xs [] = Empty (errEof)
+ walk1 (x:xs) (c:cs)| x == c = Consumed (walk xs cs)
+ | otherwise = Empty (errExpect c)
+
+ in walk1 s input)
+
+
--- /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