git.iko.soy/elk
on master help sign in
Add modules to parser. Do some minor restructuring of parser directory.
710484eevancz
elm/src/Ast.hs+12
compare with master
unifiedsplit
@@ -3,6 +3,18 @@ module Ast where
3
3
4import Data.Char (isDigit)
4import Data.Char (isDigit)
5import Data.List (intercalate)
5import Data.List (intercalate)
6+import Types
7+import Guid
8+
9+data Module = Module String Exports Imports Defs
10+
11+type Exports = [String]
12+
13+data Imports = Imports [(String, ImportMethod)]
14+data ImportMethod = As String | Hiding [String] | Importing [String]
15+
16+type Defs = [(String,Expr)]
17+
6
18
7data Pattern = PData String [Pattern] | PVar String | PAnything
19data Pattern = PData String [Pattern] | PVar String | PAnything
8 deriving (Eq)
20 deriving (Eq)
elm/src/Parse/ParseExpr.hsnew file+120
@@ -0,0 +1,120 @@
1+module ParseExpr (def) where
2+
3+import Ast
4+import Control.Applicative ((<$>), (<*>))
5+import Control.Monad
6+import Data.Char (isSymbol, isDigit)
7+import Data.List (foldl')
8+import Text.Parsec hiding (newline,spaces)
9+
10+import ParseLib
11+import Patterns
12+import Binops
13+
14+import Guid
15+import Types (Type (VarT))
16+
17+
18+-------- Basic Terms --------
19+
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+parseDef str =
118+ case parse def "" str of
119+ Right result -> Right result
120+ Left err -> Left $ "Parse error at " ++ show err
elm/src/Parse/ParseLib.hs+13−8
@@ -8,8 +8,10 @@ import Data.Char (isSymbol)
8import Text.Parsec hiding (newline,spaces)
8import Text.Parsec hiding (newline,spaces)
9
9
10reserveds = [ "if", "then", "else"
10reserveds = [ "if", "then", "else"
11− , "case", "of", "data"
11+ , "case", "of", "data"
12− , "let", "in" ]
12+ , "let", "in"
13+ , "module", "where"
14+ , "import", "as", "hiding" ]
13
15
14expecting = flip (<?>)
16expecting = flip (<?>)
15
17
@@ -46,12 +48,12 @@ arrow :: (Monad m) => ParsecT [Char] u m String
46arrow = string "->" <|> string "\8594" <?> "arrow (->)"
48arrow = string "->" <|> string "\8594" <?> "arrow (->)"
47
49
48commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
50commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
49−commaSep p = do
51+commaSep p = option [] (commaSep1 p)
50− x <- optionMaybe p
52+
51− case x of
53+commaSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
54+commaSep1 p =
52− Just a -> (a:) <$> many (try (whitespace >> (char ',' <?> "comma ','")) >>
55+ (:) <$> p <*> many (try (whitespace >> (char ',' <?> "comma ','")) >>
53− whitespace >> p)
56+ whitespace >> p)
54− Nothing -> return []
55
57
56semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
58semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
57semiSep1 p = do
59semiSep1 p = do
@@ -71,6 +73,9 @@ consSep1 p = do
71 (a:) <$> many (try (whitespace >> (char ':' <?> "cons operator ':'")) >>
73 (a:) <$> many (try (whitespace >> (char ':' <?> "cons operator ':'")) >>
72 whitespace >> p)
74 whitespace >> p)
73
75
76+dotSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
77+dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
78+
74spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
79spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
75spaceSep1 p = (:) <$> p <*> spacePrefix p
80spaceSep1 p = (:) <$> p <*> spacePrefix p
76
81
elm/src/Parse/ParseModules.hsnew file+44
@@ -0,0 +1,44 @@
1+
2+module ParseModules (moduleDef, imports) where
3+
4+import Control.Applicative ((<$>), (<*>))
5+import Data.List (intercalate)
6+import Text.Parsec hiding (newline,spaces)
7+
8+import Ast
9+import ParseLib
10+
11+moduleDef :: (Monad m) => ParsecT [Char] u m (String, [String])
12+moduleDef = do
13+ reserved "module"
14+ whitespace
15+ name <- capVar
16+ whitespace
17+ exports <- option [] . parens $ commaSep var
18+ whitespace
19+ reserved "where"
20+ return (name, exports)
21+
22+imports :: (Monad m) => ParsecT [Char] u m Imports
23+imports =
24+ Imports <$> option [] ((:) <$> import' <*> many (try (freshLine >> import')))
25+
26+
27+import' :: (Monad m) => ParsecT [Char] u m (String, ImportMethod)
28+import' = do
29+ reserved "import"
30+ whitespace
31+ name <- intercalate "." <$> dotSep1 capVar
32+ method <- option (Importing []) $ try (whitespace >>
33+ (as' <|> hiding' <|> importing'))
34+ return (name, method)
35+
36+
37+as' :: (Monad m) => ParsecT [Char] u m ImportMethod
38+as' = reserved "as" >> whitespace >> As <$> capVar
39+
40+hiding' :: (Monad m) => ParsecT [Char] u m ImportMethod
41+hiding' = reserved "hiding" >> whitespace >> Hiding <$> parens (commaSep1 var)
42+
43+importing' :: (Monad m) => ParsecT [Char] u m ImportMethod
44+importing' = Importing <$> parens (commaSep1 var)
elm/src/Parse/Parser.hs+19−110
@@ -1,4 +1,4 @@
1−module Parser (toDefs) where
1+module Parser (parseProgram) where
2
2
3import Ast
3import Ast
4import Control.Applicative ((<$>), (<*>))
4import Control.Applicative ((<$>), (<*>))
@@ -8,122 +8,31 @@ import Data.List (foldl')
8import Text.Parsec hiding (newline,spaces)
8import Text.Parsec hiding (newline,spaces)
9
9
10import ParseLib
10import ParseLib
11−import Patterns
11+import ParseExpr
12−import Binops
13import ParseTypes
12import ParseTypes
13+import ParseModules
14
14
15−import Guid
16−import Types (Type (VarT))
17
15
18−-------- Basic Terms --------
19
16
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"
119 (d:) <$> many (try (try freshLine >> (datatype <|> def)))
18 (d:) <$> many (try (try freshLine >> (datatype <|> def)))
120
19
121defs = do
20defs = do
122 (fss,ess,tss) <- unzip3 <$> defs1
21 (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
124 optional freshLine ; optional spaces ; eof
32 optional freshLine ; optional spaces ; eof
125− return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
33+ return (Module name exports is, ds)
126
34
35+parseProgram source =
127−toDefs source = case parse defs "" source of
36+ case parse program "" source of
128− Right result -> Right result
37+ Right result -> Right result
129− Left err -> Left $ "Parse error at " ++ show err
38+ Left err -> Left $ "Parse error at " ++ show err