git.iko.soy/elk
on master help sign in
Add basic module system and improve parser error messages.
267f77cevancz
elm/src/Ast.hs+2−2
compare with master
unifiedsplit
@@ -6,11 +6,11 @@ import Data.List (intercalate)
6import Types
6import Types
7import Guid
7import Guid
8
8
9−data Module = Module String Exports Imports Defs
9+data Module = Module [String] Exports Imports Defs
10
10
11type Exports = [String]
11type Exports = [String]
12
12
13−data Imports = Imports [(String, ImportMethod)]
13+type Imports = [(String, ImportMethod)]
14data ImportMethod = As String | Hiding [String] | Importing [String]
14data ImportMethod = As String | Hiding [String] | Importing [String]
15
15
16type Defs = [(String,Expr)]
16type Defs = [(String,Expr)]
elm/src/Gen/CompileToJS.hs+56−12
@@ -3,28 +3,71 @@ module CompileToJS (compile, compileToJS) where
3
3
4import Ast
4import Ast
5import Control.Monad (liftM,(<=<),join)
5import Control.Monad (liftM,(<=<),join)
6−import Data.Char (isAlpha)
6+import Data.Char (isAlpha,isDigit)
7−import Data.List (intercalate,sortBy)
7+import Data.List (intercalate,sortBy,inits)
8import Data.Map (toList)
8import Data.Map (toList)
9+import Data.Maybe (mapMaybe)
9
10
10import Initialize
11import Initialize
11
12
12showErr :: String -> String
13showErr :: String -> String
13−showErr err = "text(monospace(" ++ msg ++ "))"
14+showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
14 where msg = show . concatMap (++"<br>") . lines $ err
15 where msg = show . concatMap (++"<br>") . lines $ err
15
16
16−compile = (return . addMain . toJS) <=< initialize
17+compile str = jsModule `liftM` initialize str
17−compileToJS = addMain . either showErr toJS
18+compileToJS = either showErr jsModule
18−addMain body = "function main(){return " ++ body ++ ";}"
19
19
20parens = ("("++) . (++")")
20parens = ("("++) . (++")")
21braces = ("{"++) . (++"}")
21braces = ("{"++) . (++"}")
22jsList = ("["++) . (++"]") . intercalate ","
22jsList = ("["++) . (++"]") . intercalate ","
23jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
23jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
24−assign x e = "var " ++ x ++ "=" ++ e ++ ";"
24+assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
25−ret e = "return "++ e ++";"
25+ret e = "\nreturn "++ e ++";"
26iff a b c = a ++ "?" ++ b ++ ":" ++ c
26iff a b c = a ++ "?" ++ b ++ ":" ++ c
27
27
28+mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))
29+globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
30+
31+tryBlock e =
32+ unlines [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"
33+ , "ElmCode.main=function() {"
34+ , "var msg = ('<br><h2>Your browser may not be supported. Are you using a modern browser?</h2>' +" ++
35+ " '<br><span style=\"grey\">Runtime Error:<br>' + e + '</span>')"
36+ , "document.body.innerHTML = Text.monospace(msg);"
37+ , "throw e;"
38+ , "};}"
39+ ]
40+
41+
42+jsModule (Module names exports imports defs) =
43+ tryBlock $ unwords
44+ [ concatMap (\n -> globalAssign n $ n ++ " || {}") . map (intercalate ".") . drop 2 . inits $ take (length modNames - 1) modNames
45+ , "\nif (" ++ modName ++ ") throw 'Module name collision, " ++ intercalate "." names ++ " is already defined.'; "
46+ , globalAssign modName $ jsFunc "" (includes ++ body ++ export) ++ "()"
47+ , mainEquals $ modName ++ ".main" ]
48+ where modNames = if null names then ["ElmCode", "Main"] else "ElmCode" : names
49+ modName = intercalate "." modNames
50+ includes = concatMap jsImport $
51+ map (\(x,y) -> ("ElmCode." ++ x,y)) imports
52+ body = jsDefs defs
53+ export = ret . braces . intercalate "," $ mapMaybe getNames defs
54+ exps = if null exports then ["main"] else exports
55+ getNames (x,_) =
56+ let y = reverse . tail . dropWhile isDigit $ reverse x in
57+ if y `elem` exps then Just $ y ++ ":" ++ x else Nothing
58+
59+jsImport (modul, As name) = assign name modul
60+jsImport (modul, Importing []) = jsImport (modul, Hiding [])
61+jsImport (modul, Importing vs) =
62+ concatMap (\v -> assign v $ modul ++ "." ++ v) vs
63+jsImport (modul, Hiding vs) =
64+ unwords [ "\nfor(var i in " ++ modul ++ "){"
65+ , assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs
66+ , "\nif (hiddenVars.indexOf(i) >= 0) continue;"
67+ , globalAssign "this[i]" $ modul ++ "[i]"
68+ , "}" ]
69+
70+
28toJS expr =
71toJS expr =
29 case expr of
72 case expr of
30 Number n -> show n
73 Number n -> show n
@@ -45,13 +88,14 @@ toJS expr =
45 Case e cases -> jsCase e cases
88 Case e cases -> jsCase e cases
46 Data name es -> jsList $ show name : map toJS es
89 Data name es -> jsList $ show name : map toJS es
47
90
48−jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()"
91+jsLet defs e' = jsFunc "" (jsDefs defs ++ ret (toJS e')) ++ "()"
92+
49− where defs' = concatMap toDef $ sortBy f defs
93+jsDefs defs = concatMap toDef $ sortBy f defs
50− f a b = compare (isLambda a) (isLambda b)
94+ where f a b = compare (isLambda a) (isLambda b)
51 isLambda (_, Lambda _ _) = 1
95 isLambda (_, Lambda _ _) = 1
52 isLambda _ = 0
96 isLambda _ = 0
53 toDef (f, Lambda x e) =
97 toDef (f, Lambda x e) =
54− "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
98+ "\nfunction " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
55 toDef (x, e) = assign x (toJS e)
99 toDef (x, e) = assign x (toJS e)
56
100
57jsCase e [c] = jsMatch c ++ parens (toJS e)
101jsCase e [c] = jsMatch c ++ parens (toJS e)
elm/src/Gen/ExtractNoscript.hs+12−3
@@ -3,9 +3,10 @@ module ExtractNoscript (extract) where
3
3
4import Ast
4import Ast
5
5
6+extract (Module _ _ _ defs) =
6−extract = concatMap (\s -> "<p>" ++ s ++ "</p>") . extract'
7+ concatMap (\s -> "<p>" ++ s ++ "</p>") $ concatMap (extract' . snd) defs
7
8
8−extract' expr =
9+extract' expr =
9 let f = extract' in
10 let f = extract' in
10 case expr of
11 case expr of
11 Str s -> [s]
12 Str s -> [s]
@@ -17,10 +18,18 @@ extract' expr =
17 case (f src, f txt) of
18 case (f src, f txt) of
18 ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
19 ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
19 ( ss1, ss2) -> ss1 ++ ss2
20 ( ss1, ss2) -> ss1 ++ ss2
21+ App (Var "header") e -> tag "h1" e
22+ App (Var "bold") e -> tag "b" e
23+ App (Var "italic") e -> tag "i" e
24+ App (Var "monospace") e -> tag "code" e
20 App e1 e2 -> f e1 ++ f e2
25 App e1 e2 -> f e1 ++ f e2
21 If eb et ef -> f et ++ f ef
26 If eb et ef -> f et ++ f ef
22 Let defs e -> concatMap (f . snd) defs ++ f e
27 Let defs e -> concatMap (f . snd) defs ++ f e
23 Var _ -> []
28 Var _ -> []
24 Case e cases -> concatMap (f . snd) cases
29 Case e cases -> concatMap (f . snd) cases
25 Data _ es -> concatMap f es
30 Data _ es -> concatMap f es
26− _ -> []
31+ _ -> []
32+
33+tag t e = case extract' e of
34+ [s] -> [ concat [ "<", t, ">", s, "</", t, ">" ] ]
35+ ss -> ss
elm/src/Gen/GenerateHtml.hs+6−5
@@ -7,6 +7,7 @@ import qualified Text.Blaze.Html5 as H
7import Text.Blaze.Html5 ((!))
7import Text.Blaze.Html5 ((!))
8import qualified Text.Blaze.Html5.Attributes as A
8import qualified Text.Blaze.Html5.Attributes as A
9
9
10+import Ast
10import Initialize
11import Initialize
11import CompileToJS
12import CompileToJS
12import ExtractNoscript
13import ExtractNoscript
@@ -34,9 +35,9 @@ generateHtml :: String -- ^ Location of elm-min.js as expected by the browser
34 -> String -- ^ The elm source code.
35 -> String -- ^ The elm source code.
35 -> Html
36 -> Html
36generateHtml libLoc title source =
37generateHtml libLoc title source =
37− let expr = initialize source
38+ let modul = initialize source
38− js = compileToJS expr
39+ js = compileToJS modul
39− noscript = either id extract expr
40+ noscript = either id extract modul
40 in
41 in
41 H.docTypeHtml $ do
42 H.docTypeHtml $ do
42 H.head $ do
43 H.head $ do
@@ -49,11 +50,11 @@ generateHtml libLoc title source =
49
50
50body noscript = do
51body noscript = do
51 H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""
52 H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""
52− H.span ! A.id "content" $ ""
53+ H.div ! A.id "content" $ ""
53 H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()"
54 H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()"
54 H.noscript $ preEscapedToMarkup noscript
55 H.noscript $ preEscapedToMarkup noscript
55
56
56widgetBody noscript = do
57widgetBody noscript = do
57 H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""
58 H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""
58− H.span ! A.id "content" $ ""
59+ H.div ! A.id "content" $ ""
59 H.noscript $ preEscapedToMarkup noscript
60 H.noscript $ preEscapedToMarkup noscript
elm/src/Initialize.hs+11−94
@@ -1,100 +1,17 @@
1module Initialize (initialize) where
1module Initialize (initialize) where
2
2
3−import Ast
4−import Control.Arrow (first, second)
5−import Control.Monad
3+import Control.Monad.Error
6−import Data.Char (isAlpha)
7−import Data.Maybe (mapMaybe)
8−import Data.Either (rights)
9−
10−import Parser (toDefs)
11−import Rename (rename)
12
4
13−import Unify
5+import Ast
6+import Parser (parseProgram)
14import Hints
7import Hints
15−
8+import Unify
9+import Rename
10+import Optimize
16
11
17initialize str = do
12initialize str = do
18− (expr, hints') <- toDefs str
13+ (Module name ex im defs, tipes) <- parseProgram str
19− let expr' = rename expr
14+ let expr = rename . Let defs $ Var "_"
20− subs <- unify (liftM2 (++) hints hints') expr'
15+ subs <- unify (liftM2 (++) hints tipes) expr
21− let init = simp_loop expr'
16+ let Let defs' _ = optimize expr
22− return (seq subs init)
17+ return (subs `seq` Module name ex im defs')
23−
24−simp_loop exp = if exp == exp' then exp' else simp_loop exp'
25− where exp' = simp exp
26−
27−simp expr =
28− let f = simp in
29− case expr of
30− Range e1 e2 -> Range (f e1) (f e2)
31− Binop op e1 e2 -> simp_binop op (f e1) (f e2)
32− Lambda x e -> Lambda x (f e)
33− App e1 e2 -> App (f e1) (f e2)
34− If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
35− Let defs e -> Let (map (second f) defs) (f e)
36− Data name es -> Data name (map f es)
37− Case e cases -> Case (f e) (map (second f) cases)
38− _ -> expr
39−
40−simp_if (Boolean b) e2 e3 = if b then e2 else e3
41−simp_if a b c = If a b c
42−
43−simp_binop "mod" (Number n) (Number m) = Number (mod n m)
44−simp_binop "mod" e1 e2 = Binop "mod" e1 e2
45−simp_binop str e1 e2
46− | isAlpha (head str) || '_' == head str = App (App (Var str) e1) e2
47− | otherwise = binop str e1 e2
48−
49−binop op (Number n) (Number m) = f n m
50− where f a b = case op of
51− { "+" -> Number $ (+) a b
52− ; "-" -> Number $ (-) a b
53− ; "*" -> Number $ (*) a b
54− --; "/" -> Number $ div a b
55− ; "<" -> Boolean $ a < b
56− ; ">" -> Boolean $ a < b
57− ; "<=" -> Boolean $ a <= b
58− ; ">=" -> Boolean $ a >= b
59− ; "==" -> Boolean $ a == b
60− ; "/=" -> Boolean $ a /= b
61− ; _ -> Binop op (Number n) (Number m) }
62−
63−binop "-" e (Number 0) = e
64−binop "+" (Number 0) e = e
65−binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e
66−binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e
67−
68−binop "/" e (Number 1) = e
69−binop "*" (Number 0) e = Number 0
70−binop "*" (Number 1) e = e
71−binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e
72−binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e
73−
74−binop "+" e (Number n) = binop "+" (Number n) e
75−binop "*" e (Number n) = binop "*" (Number n) e
76−
77−binop op (Boolean n) (Boolean m) = f n m
78− where f a b = case op of { "&&" -> Boolean $ (&&) n m
79− ; "||" -> Boolean $ (||) n m
80− ; _ -> Binop op (Boolean n) (Boolean m) }
81−
82−binop "&&" (Boolean True) e = e
83−binop "&&" (Boolean False) e = Boolean False
84−binop "||" (Boolean True) e = Boolean True
85−binop "||" (Boolean False) e = e
86−
87−binop op e (Boolean n) = binop op (Boolean n) e
88−
89−binop ":" h t = cons h t
90−binop "++" (Str s1) (Str s2) = Str $ s1 ++ s2
91−binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e
92−binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2)
93−binop "++" (Data "Nil" []) e = e
94−binop "++" e (Data "Nil" []) = e
95−binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]
96−
97−binop "$" e1 e2 = App e1 e2
98−
99−binop op e1 e2 = Binop op e1 e2
100−--}
elm/src/Optimize.hsnew file+84
@@ -0,0 +1,84 @@
1+module Optimize (optimize) where
2+
3+import Ast
4+import Control.Arrow (second)
5+import Data.Char (isAlpha)
6+
7+
8+optimize exp = if exp == exp' then exp' else optimize exp'
9+ where exp' = simp exp
10+
11+simp expr =
12+ let f = simp in
13+ case expr of
14+ Range e1 e2 -> Range (f e1) (f e2)
15+ Binop op e1 e2 -> simp_binop op (f e1) (f e2)
16+ Lambda x e -> Lambda x (f e)
17+ App e1 e2 -> App (f e1) (f e2)
18+ If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
19+ Let defs e -> Let (map (second f) defs) (f e)
20+ Data name es -> Data name (map f es)
21+ Case e cases -> Case (f e) (map (second f) cases)
22+ _ -> expr
23+
24+simp_if (Boolean b) e2 e3 = if b then e2 else e3
25+simp_if a b c = If a b c
26+
27+simp_binop "mod" (Number n) (Number m) = Number (mod n m)
28+simp_binop "mod" e1 e2 = Binop "mod" e1 e2
29+simp_binop str e1 e2
30+ | isAlpha (head str) || '_' == head str = App (App (Var str) e1) e2
31+ | otherwise = binop str e1 e2
32+
33+binop op (Number n) (Number m) = f n m
34+ where f a b = case op of
35+ { "+" -> Number $ (+) a b
36+ ; "-" -> Number $ (-) a b
37+ ; "*" -> Number $ (*) a b
38+ --; "/" -> Number $ div a b
39+ ; "<" -> Boolean $ a < b
40+ ; ">" -> Boolean $ a < b
41+ ; "<=" -> Boolean $ a <= b
42+ ; ">=" -> Boolean $ a >= b
43+ ; "==" -> Boolean $ a == b
44+ ; "/=" -> Boolean $ a /= b
45+ ; _ -> Binop op (Number n) (Number m) }
46+
47+binop "-" e (Number 0) = e
48+binop "+" (Number 0) e = e
49+binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e
50+binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e
51+
52+binop "/" e (Number 1) = e
53+binop "*" (Number 0) e = Number 0
54+binop "*" (Number 1) e = e
55+binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e
56+binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e
57+
58+binop "+" e (Number n) = binop "+" (Number n) e
59+binop "*" e (Number n) = binop "*" (Number n) e
60+
61+binop op (Boolean n) (Boolean m) = f n m
62+ where f a b = case op of { "&&" -> Boolean $ (&&) n m
63+ ; "||" -> Boolean $ (||) n m
64+ ; _ -> Binop op (Boolean n) (Boolean m) }
65+
66+binop "&&" (Boolean True) e = e
67+binop "&&" (Boolean False) e = Boolean False
68+binop "||" (Boolean True) e = Boolean True
69+binop "||" (Boolean False) e = e
70+
71+binop op e (Boolean n) = binop op (Boolean n) e
72+
73+binop ":" h t = cons h t
74+binop "++" (Str s1) (Str s2) = Str $ s1 ++ s2
75+binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e
76+binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2)
77+binop "++" (Data "Nil" []) e = e
78+binop "++" e (Data "Nil" []) = e
79+binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]
80+
81+binop "$" e1 e2 = App e1 e2
82+
83+binop op e1 e2 = Binop op e1 e2
84+--}
elm/src/Parse/Binops.hs+3−4
@@ -28,10 +28,9 @@ sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
28binops term anyOp = do
28binops term anyOp = do
29 e <- term
29 e <- term
30 (ops,es) <- liftM unzip $
30 (ops,es) <- liftM unzip $
31− many (try $ do { whitespace
31+ many (commitIf (whitespace >> anyOp) $ do { whitespace ; op <- anyOp
32− ; op <- anyOp
33− ; whitespace
32+ ; whitespace ; e <- term
34− ; e <- term; return (op,e) })
33+ ; return (op,e) })
35 case binopOf Map.empty (sortOps table) ops (e:es) of
34 case binopOf Map.empty (sortOps table) ops (e:es) of
36 Right e -> return e
35 Right e -> return e
37 Left msg -> fail msg
36 Left msg -> fail msg
elm/src/Parse/ParseExpr.hs+13−12
@@ -79,16 +79,6 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
79 e <- expr
79 e <- expr
80 return $ makeFunction args e
80 return $ makeFunction args e
81
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−
92letExpr = do
82letExpr = do
93 reserved "let"
83 reserved "let"
94 brace <- optionMaybe . try $ do
84 brace <- optionMaybe . try $ do
@@ -108,13 +98,24 @@ caseExpr = do
108 where case_ = do p <- patternExpr; whitespace; arrow; whitespace
98 where case_ = do p <- patternExpr; whitespace; arrow; whitespace
109 (,) p <$> expr
99 (,) p <$> expr
110
100
101+expr = choice [ ifExpr, letExpr, caseExpr
102+ , lambdaExpr, binaryExpr ] <?> "an expression"
103+
104+assignExpr = do
105+ patterns <-
106+ choice [ try $ do v <- PVar <$> lowVar
107+ notFollowedBy (whitespace >> char ':')
108+ (v:) <$> spacePrefix patternTerm
109+ , (:[]) <$> patternExpr
110+ ] <?> "the definition of a variable (x = ...)"
111+ whitespace; string "="; whitespace; exp <- expr
112+ flattenPatterns patterns exp
111
113
112−expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ] <?> "expression"
113
114
114def = do (fs,es) <- unzip <$> assignExpr
115def = do (fs,es) <- unzip <$> assignExpr
115 return (fs, es, mapM (\_ -> liftM VarT guid) fs)
116 return (fs, es, mapM (\_ -> liftM VarT guid) fs)
116
117
117−parseDef str =
118+parseDef str =
118 case parse def "" str of
119 case parse def "" str of
119 Right result -> Right result
120 Right result -> Right result
120 Left err -> Left $ "Parse error at " ++ show err
121 Left err -> Left $ "Parse error at " ++ show err
elm/src/Parse/ParseLib.hs+20−19
@@ -42,36 +42,35 @@ anyOp :: (Monad m) => ParsecT [Char] u m String
42anyOp = betwixt '`' '`' var <|>
42anyOp = betwixt '`' '`' var <|>
43 (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
43 (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
44 guard (op `notElem` [ "=", "..", "->", "--" ])
44 guard (op `notElem` [ "=", "..", "->", "--" ])
45− return op) <?> "infix operator (e.g. x + y)"
45+ return op) <?> "infix operator (e.g. +, *, ||)"
46
46
47arrow :: (Monad m) => ParsecT [Char] u m String
47arrow :: (Monad m) => ParsecT [Char] u m String
48arrow = string "->" <|> string "\8594" <?> "arrow (->)"
48arrow = string "->" <|> string "\8594" <?> "arrow (->)"
49
49
50+
51+commitIf check p = commit <|> try p
52+ where commit = do (try $ lookAhead check) >> p
53+
50−commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
54+spaceySepBy1 :: (Monad m) => ParsecT [Char] u m b -> ParsecT [Char] u m a -> ParsecT [Char] u m [a]
51−commaSep p = option [] (commaSep1 p)
55+spaceySepBy1 sep p = do
56+ a <- p
57+ (a:) <$> many (commitIf (whitespace >> sep) (whitespace >> sep >> whitespace >> p))
58+
52
59
53commaSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
60commaSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
54−commaSep1 p =
61+commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")
55− (:) <$> p <*> many (try (whitespace >> (char ',' <?> "comma ','")) >>
62+
56− whitespace >> p)
63+commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
64+commaSep = option [] . commaSep1
57
65
58semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
66semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
59−semiSep1 p = do
60− a <- p
61− (a:) <$> many (try (whitespace >> (char ';' <?> "semicolon ';'")) >>
67+semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")
62− whitespace >> p)
63
68
64pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
69pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
65−pipeSep1 p = do
66− a <- p
67− (a:) <$> many (try (whitespace >> (char '|' <?> "type divider '|'")) >>
70+pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")
68− whitespace >> p)
69
71
70consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
72consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
71−consSep1 p = do
72− a <- p
73− (a:) <$> many (try (whitespace >> (char ':' <?> "cons operator ':'")) >>
73+consSep1 = spaceySepBy1 (char ':' <?> "cons operator ':'")
74− whitespace >> p)
75
74
76dotSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
75dotSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
77dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
76dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
@@ -79,7 +78,9 @@ dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
79spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
78spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
80spaceSep1 p = (:) <$> p <*> spacePrefix p
79spaceSep1 p = (:) <$> p <*> spacePrefix p
81
80
82−spacePrefix p = many (try (whitespace >> p))
81+spacePrefix p = many (commitIf (whitespace >> (char '[' <|> char '(')) (whitespace >> p))
82+
83+followedBy a b = do x <- a ; b ; return x
83
84
84betwixt a b c = do char a ; out <- c
85betwixt a b c = do char a ; out <- c
85 char b <?> "closing '" ++ [b] ++ "'" ; return out
86 char b <?> "closing '" ++ [b] ++ "'" ; return out
elm/src/Parse/ParseModules.hs+11−11
@@ -8,20 +8,19 @@ import Text.Parsec hiding (newline,spaces)
8import Ast
8import Ast
9import ParseLib
9import ParseLib
10
10
11−moduleDef :: (Monad m) => ParsecT [Char] u m (String, [String])
11+moduleDef :: (Monad m) => ParsecT [Char] u m ([String], [String])
12moduleDef = do
12moduleDef = do
13− reserved "module"
13+ try (reserved "module")
14− whitespace
14+ whitespace <?> "name of module"
15− name <- capVar
15+ names <- dotSep1 capVar
16 whitespace
16 whitespace
17 exports <- option [] . parens $ commaSep var
17 exports <- option [] . parens $ commaSep var
18− whitespace
18+ whitespace <?> "reserved word 'where'"
19 reserved "where"
19 reserved "where"
20− return (name, exports)
20+ return (names, exports)
21
21
22imports :: (Monad m) => ParsecT [Char] u m Imports
22imports :: (Monad m) => ParsecT [Char] u m Imports
23−imports =
24− Imports <$> option [] ((:) <$> import' <*> many (try (freshLine >> import')))
23+imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
25
24
26
25
27import' :: (Monad m) => ParsecT [Char] u m (String, ImportMethod)
26import' :: (Monad m) => ParsecT [Char] u m (String, ImportMethod)
@@ -35,10 +34,11 @@ import' = do
35
34
36
35
37as' :: (Monad m) => ParsecT [Char] u m ImportMethod
36as' :: (Monad m) => ParsecT [Char] u m ImportMethod
38−as' = reserved "as" >> whitespace >> As <$> capVar
37+as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
39
38
40hiding' :: (Monad m) => ParsecT [Char] u m ImportMethod
39hiding' :: (Monad m) => ParsecT [Char] u m ImportMethod
41−hiding' = reserved "hiding" >> whitespace >> Hiding <$> parens (commaSep1 var)
40+hiding' = reserved "hiding" >> whitespace >>
41+ Hiding <$> parens (commaSep1 var) <?> "listing of hidden values"
42
42
43importing' :: (Monad m) => ParsecT [Char] u m ImportMethod
43importing' :: (Monad m) => ParsecT [Char] u m ImportMethod
44−importing' = Importing <$> parens (commaSep1 var)
44+importing' = Importing <$> parens (commaSep1 var) <?> "listing of imported values (x,y,z)"
elm/src/Parse/ParseTypes.hs+3−3
@@ -36,7 +36,7 @@ typeSimple :: (Monad m) => ParsecT [Char] u m ParseType
36typeSimple = VarPT <$> var
36typeSimple = VarPT <$> var
37
37
38typeApp :: (Monad m) => ParsecT [Char] u m ParseType
38typeApp :: (Monad m) => ParsecT [Char] u m ParseType
39−typeApp = do name <- capVar
39+typeApp = do name <- capVar <?> "type constructor"
40 args <- spacePrefix (typeUnambiguous <|> typeSimple)
40 args <- spacePrefix (typeUnambiguous <|> typeSimple)
41 return $ case args of
41 return $ case args of
42 [] -> VarPT name
42 [] -> VarPT name
@@ -50,12 +50,12 @@ typeExpr = do
50 Nothing -> return t1
50 Nothing -> return t1
51
51
52typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
52typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
53−typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous)
53+typeConstructor = (,) <$> (capVar <?> "another type constructor") <*> spacePrefix (typeSimple <|> typeUnambiguous)
54
54
55datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
55datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
56datatype = do
56datatype = do
57 reserved "data" <?> "datatype definition (data T = A | B | ...)"
57 reserved "data" <?> "datatype definition (data T = A | B | ...)"
58− forcedWS ; name <- capVar ; args <- spacePrefix lowVar
58+ forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar
59 whitespace ; string "=" ; whitespace
59 whitespace ; string "=" ; whitespace
60 tcs <- pipeSep1 typeConstructor
60 tcs <- pipeSep1 typeConstructor
61 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
61 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
elm/src/Parse/Parser.hs+10−9
@@ -13,24 +13,25 @@ import ParseTypes
13import ParseModules
13import ParseModules
14
14
15
15
16+freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
17+ freshLine
18+ datatype <|> def <?> "another datatype or variable definition"
16
19
17−defs1 = do d <- datatype <|> def <?> "at least one definition"
20+defs1 = do d <- datatype <|> def <?> "at least one datatype or variable definition"
18− (d:) <$> many (try (try freshLine >> (datatype <|> def)))
21+ (d:) <$> many freshDef
19
22
20defs = do
23defs = do
21 (fss,ess,tss) <- unzip3 <$> defs1
24 (fss,ess,tss) <- unzip3 <$> defs1
22 return (concat fss, concat ess, concat `liftM` sequence tss)
25 return (concat fss, concat ess, concat `liftM` sequence tss)
23
26
24−
25program = do
27program = do
26 optional freshLine
28 optional freshLine
27− (name,exports) <- option ("",[]) moduleDef
29+ (names,exports) <- option ([],[]) (moduleDef `followedBy` freshLine)
28− freshLine
30+ is <- (do try (lookAhead $ reserved "import")
29− is <- imports
30− freshLine
31+ imports `followedBy` freshLine) <|> return []
31− ds <- defs
32+ (vs,es,ts) <- defs
32 optional freshLine ; optional spaces ; eof
33 optional freshLine ; optional spaces ; eof
33− return (Module name exports is, ds)
34+ return (Module names exports is $ zip vs es, zip vs `liftM` ts)
34
35
35parseProgram source =
36parseProgram source =
36 case parse program "" source of
37 case parse program "" source of