1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
module Parser(parseProgram) where
import Control.Monad
import Data.Char
import Text.Parsec
import qualified Text.Parsec.Expr as E
import AST
type Parser = Parsec String ()
(<<) :: (Monad m) => m a -> m b -> m a
(<<) = (<*)
parseProgram :: Maybe String -> String -> Either ParseError Program
parseProgram fname src = parse pProgram (maybe "" id fname) src
pProgram :: Parser Program
pProgram = (pWhiteComment >> ((Program . Block) <$> pStatement `sepBy` pWhiteComment)) << eof
pStatement :: Parser Statement
pStatement = pCondition <|> pDeclarationAssignment <|> pDive <|> pExpressionStatement <?> "statement"
pDeclarationAssignment :: Parser Statement
pDeclarationAssignment = (do
(n, constr) <- try $ do -- after we've seen the assignment operator, there's no turning back
n' <- pName
constr' <- (symbol ":=" >> return Declaration) <|> (symbol "=" >> return Assignment)
return (n', constr')
e <- pExpression
symbol ";" <|> void (lookAhead (char '}'))
return $ constr n e) <?> "variable declaration or assignment"
pCondition :: Parser Statement
pCondition = do
symbol "if"
cond <- pExpression
e1 <- pBlock
e2 <- (symbol "else" >> pBlock) <|> return (Block [])
return $ Condition cond e1 e2
pExpressionStatement :: Parser Statement
pExpressionStatement = (Expr <$> pExpression) << symbol ";"
pDive :: Parser Statement
pDive = do
n <- try $ do
n' <- pName
void $ lookAhead (oneOf "({")
return n'
al <- option [] $ between (symbol "(") (symbol ")") $ pExpression `sepBy` symbol ","
(symbol ";" >> return (Dive n al (Block []))) <|> (Dive n al <$> pBlock)
pExpression :: Parser Expression
pExpression = E.buildExpressionParser table pExpressionTerm
where
table = [[E.Prefix (symbol "-" >> return (EUn UONeg)),
E.Prefix (symbol "!" >> return (EUn UONot))],
[E.Infix (symbol "**" >> return (EBin BOPow)) E.AssocRight],
[E.Infix (symbol "*" >> return (EBin BOMul)) E.AssocLeft,
E.Infix (symbol "/" >> return (EBin BODiv)) E.AssocLeft,
E.Infix (symbol "%" >> return (EBin BOMod)) E.AssocLeft],
[E.Infix (symbol "+" >> return (EBin BOPlus)) E.AssocLeft,
E.Infix (symbol "-" >> return (EBin BOMinus)) E.AssocLeft],
[E.Infix (symbol "<=" >> return (EBin BOLEq)) E.AssocNone,
E.Infix (symbol ">=" >> return (EBin BOGEq)) E.AssocNone,
E.Infix (symbol "==" >> return (EBin BOEqual)) E.AssocNone,
E.Infix (symbol "<" >> return (EBin BOLess)) E.AssocNone,
E.Infix (symbol ">" >> return (EBin BOGreater)) E.AssocNone],
[E.Infix (symbol "&&" >> return (EBin BOBoolAnd)) E.AssocLeft,
E.Infix (symbol "||" >> return (EBin BOBoolOr)) E.AssocLeft]]
pExpressionTerm :: Parser Expression
pExpressionTerm = pParenExpression <|> (ELit <$> pLiteral)
pBlock :: Parser Block
pBlock = Block <$> between (symbol "{") (symbol "}") (many pStatement)
pParenExpression :: Parser Expression
pParenExpression = between (symbol "(") (symbol ")") pExpression
pLiteral :: Parser Literal
pLiteral = (pLNil <|> pLStr <|> pLNum <|> pLBlock <|> (LVar <$> pName)
<?> "literal") << pWhiteComment
pLNil :: Parser Literal
pLNil = symbol "nil" >> return LNil
pLBlock :: Parser Literal
pLBlock = (LBlock BT0 [] <$> pBlock) <|> do
symbol "??"
al <- option [] $ between (symbol "(") (symbol ")") $ pName `sepBy` symbol ","
b <- pBlock
return $ LBlock BT2 al b
pLNum :: Parser Literal
pLNum = pDecimal <|> pHexa
where
pDecimal = do
pre <- many1 digit <|> (lookAhead (char '.') >> return "")
post <- ((:) <$> char '.' <*> many1 digit) <|> return ""
ex <- pExponent <|> return ""
return $ LNum $ read $ pre ++ post ++ ex
pHexa = do
void $ string "0x"
pre <- many1 hexDigit
return $ LNum $ read $ "0x" ++ pre
pExponent = do
void $ char 'e'
sgn <- (char '+' >> return "") <|> string "-" <|> return ""
dig <- many1 digit
return $ 'e' : sgn ++ dig
pLStr :: Parser Literal
pLStr = LStr <$> between (char '"') (char '"') pStrContents
where
pStrContents = many pStrChar
pStrChar = (char '\\' >> pEscape) <|> noneOf "\""
pEscape = (char 'n' >> return '\n') <|>
(char 'r' >> return '\r') <|>
(char 't' >> return '\t') <|>
char '"' <|> char '\\'
pName :: Parser Name
pName = do
c <- satisfy (isAlpha .||. (== '_'))
rest <- many (satisfy (isAlphaNum .||. (== '_')))
pWhiteComment
return $ c : rest
pWhiteComment :: Parser ()
pWhiteComment = void $ pWhite `sepBy` pComment
pWhite :: Parser ()
pWhite = void $ many (oneOf " \t\n")
pComment :: Parser ()
pComment = pLineComment <|> pBlockComment
pLineComment :: Parser ()
pLineComment = void $ try (string "//") >> manyTill anyChar (void (char '\n') <|> eof)
pBlockComment :: Parser ()
pBlockComment = void $ try (string "/*") >> manyTill anyChar (try (string "*/"))
symbol :: String -> Parser ()
symbol s = do
void $ try (string s)
when (not (null s) && isAlphaNum (last s)) $ notFollowedBy alphaNum
pWhiteComment
infixr 2 .||.
(.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
f .||. g = \x -> f x || g x
|
