git.iko.soy/elk
on 46df5ff help sign in
elk/elm/src/Gen/CompileToJS.hs
196 lines 8.4 kB history raw
2module CompileToJS (showErr, jsModule) where
4import Ast
5import Control.Arrow (first)
6import Control.Monad (liftM,(<=<),join)
7import Data.Char (isAlpha,isDigit)
8import Data.List (intercalate,sortBy,inits)
9import Data.Map (toList)
10import Data.Maybe (mapMaybe)
12import Initialize
14showErr :: String -> String
15showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
16 where msg = show . concatMap (++"<br>") . lines $ err
18parens s = "(" ++ s ++ ")"
19braces s = "{" ++ s ++ "}"
20jsList ss = "["++ intercalate "," ss ++"]"
21jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
22assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
23ret e = "\nreturn "++ e ++";"
24iff a b c = a ++ "?" ++ b ++ ":" ++ c
26mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))
27globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
29tryBlock names e =
30 concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"
31 , "ElmCode.main=function() {"
32 , "var msg = ('<br><h2>Your browser may not be supported. " ++
33 "Are you using a modern browser?</h2>' +" ++
34 " '<br><span style=\"color:grey\">Runtime Error in " ++
35 intercalate "." names ++ " module:<br>' + e + '</span>');"
36 , "document.body.innerHTML = Text.monospace(msg);"
37 , "throw e;"
38 , "};}"
39 ]
42jsModule (Module names exports imports stmts) =
43 tryBlock (tail modNames) $ concat
44 [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
45 map (intercalate ".") . drop 2 . inits $
46 take (length modNames - 1) modNames
47 , "\nif (" ++ modName ++ ") throw \"Module name collision, '" ++
48 intercalate "." (tail modNames) ++ "' is already defined.\"; "
49 , globalAssign modName $ jsFunc "" (includes ++body++ export) ++ "()"
50 , mainEquals $ modName ++ ".main" ]
51 where modNames = if null names then ["ElmCode", "Main"]
52 else "ElmCode" : names
53 modName = intercalate "." modNames
54 includes = concatMap jsImport $ map (first ("ElmCode."++)) imports
55 body = stmtsToJS stmts
56 export = getExports exps stmts
57 exps = if null exports then ["main"] else exports
59stripID var
60 | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
61 | otherwise = var
63getExports names stmts = ret . braces $ intercalate "," pairs
64 where pairs = mapMaybe pair $ concatMap get stmts
65 pair x = if y `elem` names then Just $ y ++ ":" ++ x else Nothing
66 where y = stripID x
67 get s = case s of Def x _ _ -> [x]
68 Datatype _ _ tcs -> map fst tcs
69 ImportEvent _ _ x _ -> [x]
70 ExportEvent _ _ _ -> []
73jsImport (modul, how) =
74 concat [ "\ntry{" ++ modul ++ " instanceof Object} catch(e) {throw \"Module '"
75 , drop 1 (dropWhile (/='.') modul)
76 , "' is missing. Compile with --make flag or load missing "
77 , "module in a separate JavaScript file.\";}" ] ++
78 jsImport' (modul, how)
80jsImport' (modul, As name) = assign name modul
81jsImport' (modul, Importing []) = jsImport' (modul, Hiding [])
82jsImport' (modul, Importing vs) =
83 concatMap (\v -> assign v $ modul ++ "." ++ v) vs
84jsImport' (modul, Hiding vs) =
85 concat [ "\nfor(var i in " ++ modul ++ "){"
86 , assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs
87 , "\nif (hiddenVars.indexOf(i) >= 0) continue;"
88 , globalAssign "this[i]" $ modul ++ "[i]"
89 , "}" ]
91stmtsToJS :: [Statement] -> String
92stmtsToJS stmts = concatMap stmtToJS (sortBy cmpStmt stmts)
93 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
94 valueOf s = case s of Datatype _ _ _ -> 1
95 ImportEvent _ _ _ _ -> 3
96 Def _ [] _ -> 3
97 Def _ _ _ -> 4
98 ExportEvent _ _ _ -> 5
100stmtToJS :: Statement -> String
101stmtToJS (Def name [] e) = assign name (toJS e)
102stmtToJS (Def name (a:as) e) = "\nfunction " ++ name ++ parens a ++
103 braces (ret . toJS $ foldr Lambda e as) ++ ";"
104stmtToJS (Datatype _ _ tcs) = concatMap (stmtToJS . toDef) tcs
105 where toDef (name,args) = Def name vars $ Data (stripID name) (map Var vars)
106 where vars = map (('a':) . show) [1..length args]
107stmtToJS (ImportEvent js base elm _) =
108 concat [ "\nvar " ++ elm ++ " = Elm.Input(" ++ toJS base ++ ");"
109 , "\nSignal.addListener(document, '" ++ js
110 , "', function(e) { Dispatcher.notify(" ++ elm
111 , ".id, e.value); });" ]
112stmtToJS (ExportEvent js elm _) =
113 concat [ "\nlift(function(v) { var e = document.createEvent('Event');"
114 , "e.initEvent('" ++ js ++ "', true, true);"
115 , "e.value = v;"
116 , "document.dispatchEvent(e); return v; })(" ++ elm ++ ");"
117 ]
121toJS :: Expr -> String
122toJS expr =
123 case expr of
124 IntNum n -> show n
125 FloatNum n -> show n
126 Var x -> x
127 Chr c -> show c
128 Str s -> "Value.str" ++ parens (show s)
129 Boolean b -> if b then "true" else "false"
130 Range lo hi -> jsRange (toJS lo) (toJS hi)
131 Access e lbl -> toJS e ++ "." ++ lbl
132 Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
133 If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
134 Lambda v e -> jsFunc v $ ret (toJS e)
135 App (Var "toText") (Str s) -> show s
136 App (Var "link") (Str s) -> "link(" ++ show s ++ ")"
137 App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"
138 App e1 e2 -> toJS e1 ++ parens (toJS e2)
139 Let defs e -> jsLet defs e
140 Case e cases -> jsCase e cases
141 Data name es -> jsList $ show name : map toJS es
143jsLet defs e' = jsFunc "" (jsDefs defs ++ ret (toJS e')) ++ "()"
145jsDefs defs = concatMap toDef $ sortBy f defs
146 where f a b = compare (valueOf a) (valueOf b)
147 valueOf (Definition _ args _) = min 1 (length args)
148 toDef (Definition x [] e) = assign x (toJS e)
149 toDef (Definition f (a:as) e) =
150 "\nfunction " ++ f ++ parens a ++ braces (ret . toJS $ foldr Lambda e as) ++ ";"
152jsCase e [c] = jsMatch c ++ parens (toJS e)
153jsCase e cases = "(function(){" ++
154 assign "v" (toJS e) ++
155 assign "c" jsCases ++
156 "for(var i=c.length;i--;){" ++
157 assign "r" "c[i](v)" ++
158 "if(r!==undefined){return r;}}}())"
159 where jsCases = jsList $ map jsMatch (reverse cases)
161jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
162match p v hole =
163 case p of
164 PAnything -> hole
165 PVar x -> assign x v ++ hole
166 PData name ps ->
167 "if(" ++ show name ++ "!==" ++ v ++
168 "[0]){return undefined;}else{"++body++"}"
169 where matches = zipWith match ps vs
170 vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
171 body = foldr ($) hole matches
173jsNil = "[\"Nil\"]"
174jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
175jsRange e1 e2 = (++"()") . jsFunc "" $
176 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
177 "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++
178 ret "lst"
180binop (o:p) e1 e2
181 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
182 | otherwise = case o:p of
183 ":" -> jsCons e1 e2
184 "++" -> append e1 e2
185 "$" -> e1 ++ parens e2
186 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
187 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
188 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
189 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
190 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
191 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
192 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0]; return ord === 'LT' || ord === 'EQ'; }()"
193 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0]; return ord === 'GT' || ord === 'EQ'; }()"
194 _ -> parens (e1 ++ (o:p) ++ e2)
196append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)