--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/PascalBasics.hs Tue Nov 22 19:34:15 2011 +0300
@@ -0,0 +1,70 @@
+{-# LANGUAGE FlexibleContexts #-}
+module PascalBasics where
+
+import Text.Parsec.Combinator
+import Text.Parsec.Char
+import Text.Parsec.Prim
+import Text.Parsec.Token
+import Text.Parsec.Language
+import Data.Char
+
+builtin = ["succ", "pred", "low", "high"]
+
+pascalLanguageDef
+ = emptyDef
+ { commentStart = "(*"
+ , commentEnd = "*)"
+ , commentLine = "//"
+ , nestedComments = False
+ , identStart = letter <|> oneOf "_"
+ , identLetter = alphaNum <|> oneOf "_."
+ , reservedNames = [
+ "begin", "end", "program", "unit", "interface"
+ , "implementation", "and", "or", "xor", "shl"
+ , "shr", "while", "do", "repeat", "until", "case", "of"
+ , "type", "var", "const", "out", "array", "packed"
+ , "procedure", "function", "with", "for", "to"
+ , "downto", "div", "mod", "record", "set", "nil"
+ , "string", "shortstring"
+ ] ++ builtin
+ , reservedOpNames= []
+ , caseSensitive = False
+ }
+
+preprocessorSwitch :: Stream s m Char => ParsecT s u m String
+preprocessorSwitch = do
+ try $ string "{$"
+ s <- manyTill (noneOf "\n") $ char '}'
+ return s
+
+caseInsensitiveString s = do
+ mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
+ return s
+
+pas = patch $ makeTokenParser pascalLanguageDef
+ where
+ patch tp = tp {stringLiteral = stringL}
+
+comment = choice [
+ char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}')
+ , (try $ string "(*") >> manyTill anyChar (try $ string "*)")
+ , (try $ string "//") >> manyTill anyChar (try newline)
+ ]
+
+comments = do
+ spaces
+ skipMany $ do
+ preprocessorSwitch <|> comment
+ spaces
+
+stringL = do
+ (char '\'')
+ s <- (many $ noneOf "'")
+ (char '\'')
+ ss <- many $ do
+ (char '\'')
+ s' <- (many $ noneOf "'")
+ (char '\'')
+ return $ '\'' : s'
+ comments
+ return $ concat (s:ss)
--- a/tools/PascalParser.hs Tue Nov 22 02:08:42 2011 +0100
+++ b/tools/PascalParser.hs Tue Nov 22 19:34:15 2011 +0300
@@ -1,16 +1,18 @@
module PascalParser where
-import Text.Parsec.Expr
+import Text.Parsec
import Text.Parsec.Char
import Text.Parsec.Token
import Text.Parsec.Language
+import Text.Parsec.Expr
import Text.Parsec.Prim
import Text.Parsec.Combinator
import Text.Parsec.String
import Control.Monad
-import Data.Char
import Data.Maybe
+import PascalBasics
+
data PascalUnit =
Program Identifier Implementation
| Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
@@ -90,66 +92,12 @@
| InitNull
deriving Show
-builtin = ["succ", "pred", "low", "high"]
-
-pascalLanguageDef
- = emptyDef
- { commentStart = "(*"
- , commentEnd = "*)"
- , commentLine = "//"
- , nestedComments = False
- , identStart = letter <|> oneOf "_"
- , identLetter = alphaNum <|> oneOf "_."
- , reservedNames = [
- "begin", "end", "program", "unit", "interface"
- , "implementation", "and", "or", "xor", "shl"
- , "shr", "while", "do", "repeat", "until", "case", "of"
- , "type", "var", "const", "out", "array", "packed"
- , "procedure", "function", "with", "for", "to"
- , "downto", "div", "mod", "record", "set", "nil"
- , "string", "shortstring"
- ] ++ builtin
- , reservedOpNames= []
- , caseSensitive = False
- }
-
-caseInsensitiveString s = do
- mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s
- return s
-
-pas = patch $ makeTokenParser pascalLanguageDef
- where
- patch tp = tp {stringLiteral = sl}
- sl = do
- (char '\'')
- s <- (many $ noneOf "'")
- (char '\'')
- ss <- many $ do
- (char '\'')
- s' <- (many $ noneOf "'")
- (char '\'')
- return $ '\'' : s'
- comments
- return $ concat (s:ss)
-
-comments = do
- spaces
- skipMany $ do
- comment
- spaces
-
pascalUnit = do
comments
u <- choice [program, unit]
comments
return u
-comment = choice [
- char '{' >> manyTill anyChar (try $ char '}')
- , (try $ string "(*") >> manyTill anyChar (try $ string "*)")
- , (try $ string "//") >> manyTill anyChar (try newline)
- ]
-
iD = do
i <- liftM Identifier (identifier pas)
comments
@@ -389,12 +337,13 @@
term = comments >> choice [
builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n))
, parens pas $ expression
- , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
+ , try $ natural pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
, try $ float pas >>= return . FloatLiteral . show
- , try $ integer pas >>= return . NumberLiteral . show
+ , try $ natural pas >>= return . NumberLiteral . show
, stringLiteral pas >>= return . StringLiteral
, char '#' >> many digit >>= return . CharCode
, char '$' >> many hexDigit >>= return . HexNumber
+ , char '-' >> expression >>= return . PrefixOp "-"
, try $ string "nil" >> return Null
, reference >>= return . Reference
] <?> "simple expression"
@@ -407,7 +356,6 @@
]
, [ Infix (char '+' >> return (BinOp "+")) AssocLeft
, Infix (char '-' >> return (BinOp "-")) AssocLeft
- , Prefix (char '-' >> return (PrefixOp "-"))
]
, [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
, Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
@@ -626,3 +574,4 @@
exprs <- parens pas $ commaSep1 pas $ e
spaces
return (name, exprs)
+
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/PascalPreprocessor.hs Tue Nov 22 19:34:15 2011 +0300
@@ -0,0 +1,55 @@
+module PascalPreprocessor where
+
+import Text.Parsec
+import Control.Monad.IO.Class
+import System.IO
+import qualified Data.Map as Map
+
+preprocess :: String -> IO String
+preprocess fn = do
+ r <- runParserT (preprocessFile fn) Map.empty "" ""
+ case r of
+ (Left a) -> do
+ hPutStrLn stderr (show a)
+ return ""
+ (Right a) -> return a
+
+ where
+ preprocessFile :: String -> ParsecT String (Map.Map String String) IO String
+ preprocessFile fn = do
+ f <- liftIO (readFile fn)
+ setInput f
+ preprocessor
+ preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String) IO String
+ preprocessor = chainl codeBlock (return (++)) ""
+ codeBlock = choice [
+ switch
+ --, comment
+ , char '\'' >> many (noneOf "'") >>= \s -> char '\'' >> return ('\'' : s ++ "'")
+ , many1 $ noneOf "{'"
+ ]
+ switch = do
+ try $ string "{$"
+ s <- choice [
+ include
+ , unknown
+ ]
+ return s
+ include = do
+ try $ string "INCLUDE"
+ spaces
+ (char '"')
+ fn <- many1 $ noneOf "\"\n"
+ char '"'
+ spaces
+ char '}'
+ f <- liftIO (readFile fn)
+ c <- getInput
+ setInput $ f ++ c
+ return ""
+
+ unknown = do
+ fn <- many1 $ noneOf "}\n"
+ char '}'
+ return ""
+
\ No newline at end of file