@@ -19,10 +19,14 @@ showErr :: String -> String
19showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
19showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
20 where msg = show . concatMap (++"<br>") . lines $ err
20 where msg = show . concatMap (++"<br>") . lines $ err
22parens s = "(" ++ s ++ ")"
26parens s = "(" ++ s ++ ")"
23braces s = "{" ++ s ++ "}"
27braces s = "{" ++ s ++ "}"
24jsList ss = "["++ intercalate "," ss ++"]"
28jsList ss = "["++ intercalate "," ss ++"]"
25−jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
29+jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
26assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
30assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
27ret e = "\nreturn "++ e ++";"
31ret e = "\nreturn "++ e ++";"
28iff a b c = a ++ "?" ++ b ++ ":" ++ c
32iff a b c = a ++ "?" ++ b ++ ":" ++ c
@@ -31,7 +35,7 @@ mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))
31globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
35globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
33tryBlock escapees names e =
37tryBlock escapees names e =
34− concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"
38+ concat [ "\ntry{\n" ++ e ++ "\n} catch (e) {"
35 , "ElmCode.main=function() {"
39 , "ElmCode.main=function() {"
36 , "var msg = ('<br/><h2>Your browser may not be supported. " ++
40 , "var msg = ('<br/><h2>Your browser may not be supported. " ++
37 "Are you using a modern browser?</h2>' +" ++
41 "Are you using a modern browser?</h2>' +" ++
@@ -91,8 +95,8 @@ jsImport' (modul, Importing vs) =
91jsImport' (modul, Hiding vs) =
95jsImport' (modul, Hiding vs) =
92 concat [ assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs
96 concat [ assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs
93 , "\nfor(var i in " ++ modul ++ "){"
97 , "\nfor(var i in " ++ modul ++ "){"
94− , "\nif (hiddenVars.indexOf(i) >= 0) continue;"
98+ , indent $ "\nif (hiddenVars.indexOf(i) >= 0) continue;"
95− , globalAssign "this[i]" $ modul ++ "[i]"
99+ , indent $ globalAssign "this[i]" $ modul ++ "[i]"
98stmtsToJS :: [Statement] -> String
102stmtsToJS :: [Statement] -> String
@@ -107,7 +111,7 @@ stmtsToJS stmts = concatMap stmtToJS (sortBy cmpStmt stmts)
107stmtToJS :: Statement -> String
111stmtToJS :: Statement -> String
108stmtToJS (Def name [] e) = assign name (toJS e)
112stmtToJS (Def name [] e) = assign name (toJS e)
109stmtToJS (Def name (a:as) e) = "\nfunction " ++ name ++ parens a ++
113stmtToJS (Def name (a:as) e) = "\nfunction " ++ name ++ parens a ++
110− braces (ret . toJS $ foldr Lambda e as) ++ ";"
114+ braces (indent . ret . toJS $ foldr Lambda e as) ++ ";"
111stmtToJS (Datatype _ _ tcs) = concatMap (stmtToJS . toDef) tcs
115stmtToJS (Datatype _ _ tcs) = concatMap (stmtToJS . toDef) tcs
112 where toDef (name,args) = Def name vars $ Data (derename name) (map Var vars)
116 where toDef (name,args) = Def name vars $ Data (derename name) (map Var vars)
113 where vars = map (('a':) . show) [1..length args]
117 where vars = map (('a':) . show) [1..length args]
@@ -167,36 +171,31 @@ jsDefs defs = concat `liftM` mapM toDef (sortBy f defs)
167 toDef (Definition x [] e) = assign x `liftM` toJS' e
171 toDef (Definition x [] e) = assign x `liftM` toJS' e
168 toDef (Definition f (a:as) e) = do
172 toDef (Definition f (a:as) e) = do
169 out <- toJS' $ foldr Lambda e as
173 out <- toJS' $ foldr Lambda e as
170− return $ "\nfunction " ++ f ++ parens a ++ braces (ret out) ++ ";"
174+ return $ "\nfunction " ++ f ++ parens a ++ braces (indent $ ret out) ++ ";"
172caseToJS e ps = do
176caseToJS e ps = do
173 match <- caseToMatch ps
177 match <- caseToMatch ps
174− var <- liftM (\n -> "case" ++ show n) guid
175− matches <- matchToJS var match
176 e' <- toJS' e
178 e' <- toJS' e
177− return $ concat [ "function(", var, "){"
179+ (match',stmt) <- case (match,e) of
180+ (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")
178− , case match of { Match name _ _ -> assign name var ; _ -> "" }
181+ (Match name _ _, _ ) -> return (match, assign name e')
179− , matches
182+ _ -> liftM (\n -> (match, e')) guid
180− , "}", parens e' ]
183+ matches <- matchToJS match'
181−
184+ return $ concat [ "function(){", stmt, matches, "}()" ]
182−matchToJS v (Match name clauses def) = do
186+matchToJS (Match name clauses def) = do
183 cases <- concat `liftM` mapM (clauseToJS name) clauses
187 cases <- concat `liftM` mapM (clauseToJS name) clauses
184− finally <- matchToJS v def
188+ finally <- matchToJS def
185− return $ concat [ "\nswitch(", name, "[0]){", cases, "\n}", finally ]
189+ return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
186−matchToJS _ Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
190+matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
187−matchToJS _ Break = return "break;"
191+matchToJS Break = return "break;"
188−matchToJS _ (Other e) = ret `liftM` toJS' e
192+matchToJS (Other e) = ret `liftM` toJS' e
189−matchToJS v (Seq ms) = concat `liftM` mapM (matchToJS v) ms
193+matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms
191clauseToJS var (Clause name vars e) = do
195clauseToJS var (Clause name vars e) = do
196+ let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
192− s <- matchToJS var e
197+ s <- matchToJS $ matchSubst (zip vars vars') e
193− return $ concat [ "\ncase ", show name, ":"
198+ return $ concat [ "\ncase ", show name, ":", s ]
196− where toDef v n = v ++ "=" ++ var ++ "[" ++ show n ++ "]"
197− defs = case vars of [] -> ""
198− _ -> ("\nvar "++) . (++";") . intercalate "," $
199− zipWith toDef vars [ 1 .. length vars ]
201jsNil = "[\"Nil\"]"
200jsNil = "[\"Nil\"]"
202jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
201jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]