1 module PascalParser where |
1 module PascalParser where |
2 |
2 |
3 import Text.Parsec.Expr |
3 import Text.Parsec |
4 import Text.Parsec.Char |
4 import Text.Parsec.Char |
5 import Text.Parsec.Token |
5 import Text.Parsec.Token |
6 import Text.Parsec.Language |
6 import Text.Parsec.Language |
|
7 import Text.Parsec.Expr |
7 import Text.Parsec.Prim |
8 import Text.Parsec.Prim |
8 import Text.Parsec.Combinator |
9 import Text.Parsec.Combinator |
9 import Text.Parsec.String |
10 import Text.Parsec.String |
10 import Control.Monad |
11 import Control.Monad |
11 import Data.Char |
|
12 import Data.Maybe |
12 import Data.Maybe |
|
13 |
|
14 import PascalBasics |
13 |
15 |
14 data PascalUnit = |
16 data PascalUnit = |
15 Program Identifier Implementation |
17 Program Identifier Implementation |
16 | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize) |
18 | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize) |
17 deriving Show |
19 deriving Show |
88 | BuiltInFunction String [InitExpression] |
90 | BuiltInFunction String [InitExpression] |
89 | InitSet [Identifier] |
91 | InitSet [Identifier] |
90 | InitNull |
92 | InitNull |
91 deriving Show |
93 deriving Show |
92 |
94 |
93 builtin = ["succ", "pred", "low", "high"] |
|
94 |
|
95 pascalLanguageDef |
|
96 = emptyDef |
|
97 { commentStart = "(*" |
|
98 , commentEnd = "*)" |
|
99 , commentLine = "//" |
|
100 , nestedComments = False |
|
101 , identStart = letter <|> oneOf "_" |
|
102 , identLetter = alphaNum <|> oneOf "_." |
|
103 , reservedNames = [ |
|
104 "begin", "end", "program", "unit", "interface" |
|
105 , "implementation", "and", "or", "xor", "shl" |
|
106 , "shr", "while", "do", "repeat", "until", "case", "of" |
|
107 , "type", "var", "const", "out", "array", "packed" |
|
108 , "procedure", "function", "with", "for", "to" |
|
109 , "downto", "div", "mod", "record", "set", "nil" |
|
110 , "string", "shortstring" |
|
111 ] ++ builtin |
|
112 , reservedOpNames= [] |
|
113 , caseSensitive = False |
|
114 } |
|
115 |
|
116 caseInsensitiveString s = do |
|
117 mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s <?> s |
|
118 return s |
|
119 |
|
120 pas = patch $ makeTokenParser pascalLanguageDef |
|
121 where |
|
122 patch tp = tp {stringLiteral = sl} |
|
123 sl = do |
|
124 (char '\'') |
|
125 s <- (many $ noneOf "'") |
|
126 (char '\'') |
|
127 ss <- many $ do |
|
128 (char '\'') |
|
129 s' <- (many $ noneOf "'") |
|
130 (char '\'') |
|
131 return $ '\'' : s' |
|
132 comments |
|
133 return $ concat (s:ss) |
|
134 |
|
135 comments = do |
|
136 spaces |
|
137 skipMany $ do |
|
138 comment |
|
139 spaces |
|
140 |
|
141 pascalUnit = do |
95 pascalUnit = do |
142 comments |
96 comments |
143 u <- choice [program, unit] |
97 u <- choice [program, unit] |
144 comments |
98 comments |
145 return u |
99 return u |
146 |
|
147 comment = choice [ |
|
148 char '{' >> manyTill anyChar (try $ char '}') |
|
149 , (try $ string "(*") >> manyTill anyChar (try $ string "*)") |
|
150 , (try $ string "//") >> manyTill anyChar (try newline) |
|
151 ] |
|
152 |
100 |
153 iD = do |
101 iD = do |
154 i <- liftM Identifier (identifier pas) |
102 i <- liftM Identifier (identifier pas) |
155 comments |
103 comments |
156 return i |
104 return i |
387 expression = buildExpressionParser table term <?> "expression" |
335 expression = buildExpressionParser table term <?> "expression" |
388 where |
336 where |
389 term = comments >> choice [ |
337 term = comments >> choice [ |
390 builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n)) |
338 builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n)) |
391 , parens pas $ expression |
339 , parens pas $ expression |
392 , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i |
340 , try $ natural pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i |
393 , try $ float pas >>= return . FloatLiteral . show |
341 , try $ float pas >>= return . FloatLiteral . show |
394 , try $ integer pas >>= return . NumberLiteral . show |
342 , try $ natural pas >>= return . NumberLiteral . show |
395 , stringLiteral pas >>= return . StringLiteral |
343 , stringLiteral pas >>= return . StringLiteral |
396 , char '#' >> many digit >>= return . CharCode |
344 , char '#' >> many digit >>= return . CharCode |
397 , char '$' >> many hexDigit >>= return . HexNumber |
345 , char '$' >> many hexDigit >>= return . HexNumber |
|
346 , char '-' >> expression >>= return . PrefixOp "-" |
398 , try $ string "nil" >> return Null |
347 , try $ string "nil" >> return Null |
399 , reference >>= return . Reference |
348 , reference >>= return . Reference |
400 ] <?> "simple expression" |
349 ] <?> "simple expression" |
401 |
350 |
402 table = [ |
351 table = [ |
405 , Infix (try (string "div") >> return (BinOp "div")) AssocLeft |
354 , Infix (try (string "div") >> return (BinOp "div")) AssocLeft |
406 , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft |
355 , Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft |
407 ] |
356 ] |
408 , [ Infix (char '+' >> return (BinOp "+")) AssocLeft |
357 , [ Infix (char '+' >> return (BinOp "+")) AssocLeft |
409 , Infix (char '-' >> return (BinOp "-")) AssocLeft |
358 , Infix (char '-' >> return (BinOp "-")) AssocLeft |
410 , Prefix (char '-' >> return (PrefixOp "-")) |
|
411 ] |
359 ] |
412 , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone |
360 , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone |
413 , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone |
361 , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone |
414 , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone |
362 , Infix (try (string ">=") >> return (BinOp ">=")) AssocNone |
415 , Infix (char '<' >> return (BinOp "<")) AssocNone |
363 , Infix (char '<' >> return (BinOp "<")) AssocNone |