@@ -1,4 +1,4 @@
1−module Parser (toDefs) where
1+module Parser (parseProgram) where
22
33import Ast
44import Control.Applicative ((<$>), (<*>))
@@ -8,122 +8,31 @@ import Data.List (foldl')
88import Text.Parsec hiding (newline,spaces)
99
1010import ParseLib
11−import Patterns
12−import Binops
11+import ParseExpr
1312import ParseTypes
13+import ParseModules
1414
15−import Guid
16−import Types (Type (VarT))
1715
18−-------- Basic Terms --------
1916
20−numTerm :: (Monad m) => ParsecT [Char] u m Expr
21−numTerm = liftM (Number . read) (many1 digit) <?> "number"
22−
23−strTerm :: (Monad m) => ParsecT [Char] u m Expr
24−strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $
25− backslashed <|> satisfy (/='"')
26−
27−varTerm :: (Monad m) => ParsecT [Char] u m Expr
28−varTerm = toVar <$> var <?> "variable"
29−
30−toVar v = case v of "True" -> Boolean True
31− "False" -> Boolean False
32− _ -> Var v
33−
34−chrTerm :: (Monad m) => ParsecT [Char] u m Expr
35−chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
36− <?> "character"
37−
38−
39−-------- Complex Terms --------
40−
41−listTerm = braces $ choice
42− [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
43− ; Range lo <$> expr }
44− , list <$> commaSep expr
45− ]
46−
47−parensTerm = parens $ choice
48− [ do op <- anyOp
49− return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
50− , do es <- commaSep expr
51− return $ case es of { [e] -> e; _ -> tuple es }
52− ]
53−
54−term = choice [ numTerm, strTerm, chrTerm
55− , accessible varTerm
56− , listTerm, parensTerm ]
57− <?> "basic term (4, x, 'c', etc.)"
58−
59−-------- Applications --------
60−
61−appExpr = do
62− tlist <- spaceSep1 term
63− return $ case tlist of
64− t:[] -> t
65− t:ts -> foldl' App t ts
66−
67−-------- Normal Expressions --------
68−
69−binaryExpr = binops appExpr anyOp
70−
71−ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
72− reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
73− reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
74−
75−lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
76− whitespace
77− args <- spaceSep1 patternTerm
78− whitespace ; arrow ; whitespace
79− e <- expr
80− return $ makeFunction args e
81−
82−assignExpr = do
83− patterns <-
84− choice [ try $ do v <- PVar <$> lowVar
85− notFollowedBy (whitespace >> char ':')
86− (v:) <$> spacePrefix patternTerm
87− , (:[]) <$> patternExpr
88− ] <?> "the definition of a variable (x = ...)"
89− whitespace; string "="; whitespace; exp <- expr
90− flattenPatterns patterns exp
91−
92−letExpr = do
93− reserved "let"
94− brace <- optionMaybe . try $ do
95− whitespace
96− char '{' <?> "a set of definitions { x = ... ; y = ... }"
97− case brace of
98− Nothing -> do whitespace; ds <- assignExpr
99− whitespace; reserved "in"; whitespace; Let ds <$> expr
100− Just '{' -> do whitespace ; dss <- semiSep1 assignExpr ; whitespace
101− string "}" <?> "closing bracket '}'"
102− whitespace; reserved "in"; whitespace; e <- expr
103− return $ Let (concat dss) e
104−
105−caseExpr = do
106− reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
107− Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
108− where case_ = do p <- patternExpr; whitespace; arrow; whitespace
109− (,) p <$> expr
110−
111−
112−expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ] <?> "expression"
113−
114−def = do (fs,es) <- unzip <$> assignExpr
115− return (fs, es, mapM (\_ -> liftM VarT guid) fs)
116−
117−defs1 = do optional freshLine
118− d <- datatype <|> def
17+defs1 = do d <- datatype <|> def <?> "at least one definition"
11918 (d:) <$> many (try (try freshLine >> (datatype <|> def)))
12019
12120defs = do
12221 (fss,ess,tss) <- unzip3 <$> defs1
123− let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
22+ return (concat fss, concat ess, concat `liftM` sequence tss)
23+
24+
25+program = do
26+ optional freshLine
27+ (name,exports) <- option ("",[]) moduleDef
28+ freshLine
29+ is <- imports
30+ freshLine
31+ ds <- defs
12432 optional freshLine ; optional spaces ; eof
125− return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
33+ return (Module name exports is, ds)
12634
127−toDefs source = case parse defs "" source of
128− Right result -> Right result
129− Left err -> Left $ "Parse error at " ++ show err
35+parseProgram source =
36+ case parse program "" source of
37+ Right result -> Right result
38+ Left err -> Left $ "Parse error at " ++ show err