git.iko.soy/elk
on cbecda2 help sign in
elk/elm/src/Gen/CompileToJS.hs
163 lines 6.7 kB history raw
2module CompileToJS (showErr, jsModule) where
4import Ast
5import Control.Monad (liftM,(<=<),join)
6import Data.Char (isAlpha,isDigit)
7import Data.List (intercalate,sortBy,inits)
8import Data.Map (toList)
9import Data.Maybe (mapMaybe)
11import Initialize
13showErr :: String -> String
14showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
15 where msg = show . concatMap (++"<br>") . lines $ err
17parens s = "(" ++ s ++ ")"
18braces s = "{" ++ s ++ "}"
19jsList ss = "["++ intercalate "," ss ++"]"
20jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
21assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
22ret e = "\nreturn "++ e ++";"
23iff a b c = a ++ "?" ++ b ++ ":" ++ c
25mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))
26globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
28tryBlock names e =
29 concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"
30 , "ElmCode.main=function() {"
31 , "var msg = ('<br><h2>Your browser may not be supported. " ++
32 "Are you using a modern browser?</h2>' +" ++
33 " '<br><span style=\"color:grey\">Runtime Error in " ++
34 intercalate "." names ++ " module:<br>' + e + '</span>');"
35 , "document.body.innerHTML = Text.monospace(msg);"
36 , "throw e;"
37 , "};}"
38 ]
41jsModule (Module names exports imports defs foreigns) =
42 tryBlock (tail modNames) $ concat
43 [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
44 map (intercalate ".") . drop 2 . inits $
45 take (length modNames - 1) modNames
46 , "\nif (" ++ modName ++ ") throw \"Module name collision, '" ++
47 intercalate "." (tail modNames) ++ "' is already defined.\"; "
48 , globalAssign modName $ jsFunc "" (includes++ims++body++exs++export)++"()"
49 , mainEquals $ modName ++ ".main" ]
50 where modNames = if null names then ["ElmCode", "Main"] else "ElmCode" : names
51 modName = intercalate "." modNames
52 includes = concatMap jsImport $
53 map (\(x,y) -> ("ElmCode." ++ x,y)) imports
54 body = jsDefs defs
55 export = ret . braces . intercalate "," $ mapMaybe getNames defs
56 exps = if null exports then ["main"] else exports
57 getNames (x,_) =
58 let y = reverse . tail . dropWhile isDigit $ reverse x in
59 if y `elem` exps then Just $ y ++ ":" ++ x else Nothing
60 (ims,exs) = let (i,e) = foreigns in
61 (concatMap importEvent i, concatMap exportEvent e)
63importEvent (js,base,elm,_) =
64 concat [ "\nvar " ++ elm ++ " = Elm.Input(" ++ toJS base ++ ");"
65 , "\nSignal.addListener(document, '" ++ js
66 , "', function(e) { Dispatcher.notify(" ++ elm
67 , ".id, e.value); });" ]
68exportEvent (js,elm,_) =
69 concat [ "\nlift(function(v) { var e = document.createEvent('Event');"
70 , "e.initEvent('" ++ js ++ "', true, true);"
71 , "e.value = v;"
72 , "document.dispatchEvent(e); return v; })(" ++ elm ++ ");"
73 ]
75jsImport (modul, how) =
76 concat [ "\ntry{" ++ modul ++ " instanceof Object} catch(e) {throw \"Module '"
77 , drop 1 (dropWhile (/='.') modul)
78 , "' is missing. Compile with --make flag or load missing "
79 , "module in a separate JavaScript file.\";}" ] ++
80 jsImport' (modul, how)
82jsImport' (modul, As name) = assign name modul
83jsImport' (modul, Importing []) = jsImport' (modul, Hiding [])
84jsImport' (modul, Importing vs) =
85 concatMap (\v -> assign v $ modul ++ "." ++ v) vs
86jsImport' (modul, Hiding vs) =
87 concat [ "\nfor(var i in " ++ modul ++ "){"
88 , assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs
89 , "\nif (hiddenVars.indexOf(i) >= 0) continue;"
90 , globalAssign "this[i]" $ modul ++ "[i]"
91 , "}" ]
94toJS expr =
95 case expr of
96 Number n -> show n
97 Var x -> x
98 Chr c -> show c
99 Str s -> "Value.str" ++ parens (show s)
100 Boolean b -> if b then "true" else "false"
101 Range lo hi -> jsRange (toJS lo) (toJS hi)
102 Access e lbl -> toJS e ++ "." ++ lbl
103 Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
104 If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
105 Lambda v e -> jsFunc v $ ret (toJS e)
106 App (Var "toText") (Str s) -> show s
107 App (Var "link") (Str s) -> "link(" ++ show s ++ ")"
108 App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"
109 App e1 e2 -> toJS e1 ++ parens (toJS e2)
110 Let defs e -> jsLet defs e
111 Case e cases -> jsCase e cases
112 Data name es -> jsList $ show name : map toJS es
114jsLet defs e' = jsFunc "" (jsDefs defs ++ ret (toJS e')) ++ "()"
116jsDefs defs = concatMap toDef $ sortBy f defs
117 where f a b = compare (isLambda a) (isLambda b)
118 isLambda (_, Lambda _ _) = 1
119 isLambda _ = 0
120 toDef (f, Lambda x e) =
121 "\nfunction " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
122 toDef (x, e) = assign x (toJS e)
124jsCase e [c] = jsMatch c ++ parens (toJS e)
125jsCase e cases = "(function(){" ++
126 assign "v" (toJS e) ++
127 assign "c" jsCases ++
128 "for(var i=c.length;i--;){" ++
129 assign "r" "c[i](v)" ++
130 "if(r!==undefined){return r;}}}())"
131 where jsCases = jsList $ map jsMatch (reverse cases)
133jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
134match p v hole =
135 case p of
136 PAnything -> hole
137 PVar x -> assign x v ++ hole
138 PData name ps ->
139 "if(" ++ show name ++ "!==" ++ v ++
140 "[0]){return undefined;}else{"++body++"}"
141 where matches = zipWith match ps vs
142 vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
143 body = foldr ($) hole matches
145jsNil = "[\"Nil\"]"
146jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
147jsRange e1 e2 = (++"()") . jsFunc "" $
148 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
149 "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++
150 ret "lst"
152binop (o:p) e1 e2
153 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
154 | otherwise = case o:p of
155 ":" -> jsCons e1 e2
156 "++" -> append e1 e2
157 "$" -> e1 ++ parens e2
158 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
159 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
160 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
161 _ -> parens (e1 ++ (o:p) ++ e2)
163append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)