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
|
module Haskell.Parser where
import Control.Monad
import Control.Monad.Identity
import Haskell.AST
import Haskell.Parser.Def
import Text.Parsec
-- import Text.Parsec.IndentParsec.Combinator
import Text.Parsec.IndentParsec.Prim
type Parser a = GenIndentParsecT HaskellLike String () Identity a
parseAST :: String -> String -> Either ParseError AST
parseAST fname source = runIdentity $ runGIPT pAST () fname source
pAST :: Parser AST
pAST = do
whiteSpace
tops <- pToplevel `sepBy` someNewline
eof
return $ AST tops
pToplevel :: Parser Toplevel
pToplevel = choice [TopClass <$> pClass
,TopInst <$> pInst
,TopData <$> pData
,TopDecl <$> pDecl
,TopDef <$> pDef]
pData :: Parser Data
pData = do
reserved "data"
n <- typeident
vars <- many varident
ty <- choice [do reservedOp "="
pConstr `sepBy` reservedOp "|"
,return []]
return $ Data n vars ty
where
pConstr = liftM2 (,) typeident (many pType)
pClass :: Parser Class
pClass = do
reserved "class"
n <- typeident
vars <- many varident
reserved "where"
decls <- bracesBlock (semiSepOrFoldedLines pDecl)
return $ Class n vars decls
pInst :: Parser Inst
pInst = do
reserved "instance"
(n, ty) <- pType >>= \case
TyRef n [ty] -> return (n, ty)
_ -> fail "invalid instance head"
reserved "where"
decls <- bracesBlock (semiSepOrFoldedLines pDef)
return $ Inst n ty decls
pDecl :: Parser Decl
pDecl = do
n <- try (varident <* reservedOp "::")
ty <- pType
return $ Decl n ty
pDef :: Parser Def
pDef = do
n <- varident
args <- many varident
reservedOp "="
body <- pExpr
case args of
[] -> return $ Def n body
_ -> return $ Def n (Lam args body)
pType :: Parser Type
pType = foldr1 TyFun <$> pSimpleType `sepBy` reservedOp "->"
where
pSimpleType :: Parser Type
pSimpleType = choice [do n <- typeident
args <- many pAtomicType
return (TyRef n args)
,pAtomicType]
pAtomicType :: Parser Type
pAtomicType = choice [typeident >>= \n -> return (TyRef n [])
,TyVar <$> varident
,parens (pType `sepBy` comma) >>= \case
[ty] -> return ty
tys -> return (TyTup tys)]
pExpr :: Parser Expr
pExpr = pLam <|> pCase <|> pApp
where
pSimpleExpr = choice [Num <$> integer
,Ref <$> (identifier <|> try (parens operator))
,parens pExpr]
pLam = do
reservedOp "\\"
args <- many1 varident
body <- pExpr
return $ Lam args body
pApp = App <$> pSimpleExpr <*> many pSimpleExpr
pCase = do
reserved "case"
e <- pExpr
reserved "of"
arms <- bracesBlock (semiSepOrFoldedLines pCaseArm)
return $ Case e arms
pCaseArm = do
pat <- pLargePat
reservedOp "->"
ex <- pExpr
return (pat, ex)
pSimplePat :: Parser Pat
pSimplePat = choice [lexeme (string "_") >> return PatAny
,PatVar <$> varident
,typeident >>= \n -> return (PatCon n [])
,parens pLargePat]
pLargePat :: Parser Pat
pLargePat = choice [PatCon <$> typeident <*> many pSimplePat
,pSimplePat]
someNewline :: Parser ()
someNewline = many (oneOf " \t") >> char '\n' >> whiteSpace
|
