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
|
module Haskell.Parser where
import Control.Monad
import Data.Char
import Haskell.AST
import Text.Parsec
import Text.Parsec.String
parseAST :: String -> String -> Either ParseError AST
parseAST fname source = parse pAST fname source
pAST :: Parser AST
pAST = do
whitespace
tops <- many pToplevel
eof
return $ AST tops
pToplevel :: Parser Toplevel
pToplevel = TopDef <$> pDef
pDef :: Parser Def
pDef = do
n <- pVariable
args <- many pNameV
symbolO "="
ex <- pExpr
symbolO ";"
case args of
[] -> return $ Def n ex
_ -> return $ Def n (Lam args ex)
pExpr :: Parser Expr
pExpr = pLam <|> pCase <|> pApp
where
pSimpleExpr = choice [Num <$> pNum
,Ref <$> pVariable
,parens (pExpr `sepBy` symbolO ",") >>= \case
[ex] -> return ex
exs -> return $ Tup exs]
pLam = do
symbolO "\\"
args <- many1 pNameV
body <- pExpr
return $ Lam args body
pApp = many1 pSimpleExpr >>= \case
[] -> undefined
[e] -> return e
(e:es) -> return $ App e es
pCase = do
symbolW "case"
e <- pExpr
symbolW "of"
arms <- braces (pCaseArm `sepBy` symbolO ";")
return $ Case e arms
pCaseArm = do
pat <- pLargePat
symbolO "->"
ex <- pExpr
return (pat, ex)
pSimplePat :: Parser Pat
pSimplePat = choice [symbolW "_" >> return PatAny
,PatVar <$> pNameV
,pNameT >>= \n -> return (PatCon n [])
,parens (pLargePat `sepBy` symbolO ",") >>= \case
[pat] -> return pat
pats -> return $ PatTup pats]
pLargePat :: Parser Pat
pLargePat = choice [PatCon <$> pNameT <*> many pSimplePat
,pSimplePat]
pNum :: Parser Integer
pNum = (char '-' >> (negate <$> pPositive)) <|> pPositive
where pPositive = read <$> many1 digit
pVariable :: Parser Name
pVariable = pName <|> try (parens pOperator)
pName :: Parser Name
pName = notReserved $ liftM2 (:) (satisfy isAlpha) pNameRest
pNameV :: Parser Name
pNameV = notReserved $ liftM2 (:) (satisfy isLower) pNameRest
pNameT :: Parser Name
pNameT = notReserved $ liftM2 (:) (satisfy isUpper) pNameRest
pNameRest :: Parser Name
pNameRest = many (satisfy $ \d -> isAlphaNum d || d == '_') <* aheadW
notReserved :: Parser Name -> Parser Name
notReserved p =
try $ p >>= \n ->
if n `elem` reservedWords then unexpected "reserved word" else return n
pOperator :: Parser String
pOperator = many1 (oneOf ":!#$%&*+./<=>?@\\^|-~") <* aheadO
parens :: Parser a -> Parser a
parens = between (symbolBare "(") (symbolBare ")")
braces :: Parser a -> Parser a
braces = between (symbolBare "{") (symbolBare "}")
symbolW :: String -> Parser ()
symbolW s = string s >> aheadW
symbolO :: String -> Parser ()
symbolO s = string s >> aheadO
symbolBare :: String -> Parser ()
symbolBare s = string s >> whitespace
aheadW :: Parser ()
aheadW = do
void (lookAhead (space <|> satisfy (\d -> not (isAlphaNum d) && d /= '_'))) <|> eof
whitespace
aheadO :: Parser ()
aheadO = do
void (lookAhead (space <|> alphaNum <|> oneOf ")};")) <|> eof
whitespace
whitespace :: Parser ()
whitespace = void $ many space
reservedWords :: [String]
reservedWords = ["case", "of", "class", "instance", "where", "let", "in"]
|
