blob: 26308deb5607f66e3873be899c0d27773c198ed6 (
plain)
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
|
module Haskell.SimpleParser 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 <- pNameV
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 [LitNum <$> pNum
,Ref <$> (pName <|> try (parens pOperator))
,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"
n <- pNameV
symbolW "of"
arms <- braces (pCaseArm `sepBy` symbolO ";")
return $ Case n 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
pName :: Parser Name
pName = liftM2 (:) (satisfy isAlpha) pNameRest
pNameV :: Parser Name
pNameV = liftM2 (:) (satisfy isLower) pNameRest
pNameT :: Parser Name
pNameT = liftM2 (:) (satisfy isUpper) pNameRest
pNameRest :: Parser Name
pNameRest = many (satisfy $ \d -> isAlphaNum d || d == '_') <* aheadW
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
|