git.iko.soy/elk
on cb609ea help sign in
elk/elm/src/Gen/CompileToJS.hs
330 lines 14 kB history raw
1module CompileToJS (showErr, jsModule) where
3import Ast
4import Context
5import Control.Arrow (first)
6import Control.Monad (liftM,(<=<),join,ap)
7import Data.Char (isAlpha,isDigit)
8import Data.List (intercalate,sortBy,inits,foldl')
9import qualified Data.Map as Map
10import Data.Either (partitionEithers)
11import qualified Text.Pandoc as Pan
13import Initialize
14import Rename (derename)
15import Cases
16import Guid
17import Parse.Library (isOp)
18import Rename (deprime)
20showErr :: String -> String
21showErr err = mainEquals $ "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
22 where msg = show . concatMap (++"<br>") . lines $ err
24indent = concatMap f
25 where f '\n' = "\n "
26 f c = [c]
28parens s = "(" ++ s ++ ")"
29braces s = "{" ++ s ++ "}"
30jsList ss = "["++ intercalate "," ss ++"]"
31jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
32assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
33ret e = "\nreturn "++ e ++";"
34iff a b c = a ++ "?" ++ b ++ ":" ++ c
35quoted s = "'" ++ concatMap f s ++ "'"
36 where f '\n' = "\\n"
37 f '\'' = "\\'"
38 f '\t' = "\\t"
39 f '\"' = "\\\""
40 f '\\' = "\\\\"
41 f c = [c]
43mainEquals s = globalAssign "Elm.main" (jsFunc "" (ret s))
44globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
46tryBlock escapees names e =
47 concat [ "\ntry{\n" ++ e ++ "\n} catch (e) {"
48 , "\nElm.main=function() {"
49 , "\nvar msg = ('<br/><h2>Your browser may not be supported. " ++
50 "Are you using a modern browser?</h2>' +" ++
51 " '<br/><span style=\"color:grey\">Runtime Error in " ++
52 intercalate "." names ++ " module:<br/>' + e + '" ++ msg ++ "</span>');"
53 , "\ndocument.body.innerHTML = Elm.Text.monospace(msg);"
54 , "throw e;"
55 , "};}"
56 ]
57 where msg | escapees /= [] = concat [ "<br/><br/>The problem may stem from an improper usage of:<br/>"
58 , intercalate ", " $ map (concatMap escape) escapees ]
59 | otherwise = ""
60 escape '\'' = "\\'"
61 escape '"' = "\\\""
62 escape c = [c]
65jsModule (escapees, Module names exports imports stmts) =
66 tryBlock escapees (tail modNames) $ concat
67 [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
68 map (intercalate ".") . drop 2 . inits $
69 take (length modNames - 1) modNames
70 , "\nif (" ++ modName ++ ") throw new Error(\"Module name collision, '" ++
71 intercalate "." (tail modNames) ++ "' is already defined.\"); "
72 , globalAssign modName $ jsFunc "" (defs ++ includes ++ body ++ export) ++ "()"
73 , mainEquals $ modName ++ ".main" ]
74 where modNames = if null names then ["Elm", "Main"]
75 else "Elm" : names
76 modName = intercalate "." modNames
77 includes = concatMap jsImport $ map (first ("Elm."++)) imports
78 body = stmtsToJS stmts
79 export = getExports exports stmts
80 exps = if null exports then ["main"] else exports
81 defs = concat [ assign "$op" "{}"
82 , "\nfor(Elm['i'] in Elm){eval('var '+Elm['i']+'=Elm[Elm.i];');}" ]
84getExports names stmts = ret . braces $ intercalate ",\n" (op : map fnPair fns)
85 where exNames n = either derename id n `elem` names
86 exports | null names = concatMap get stmts
87 | otherwise = filter exNames (concatMap get stmts)
89 (fns,ops) = partitionEithers exports
91 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
92 fnPair fn = let fn' = derename fn in fn' ++ ":" ++ fn
94 op = ("$op : "++) . braces . intercalate ", " $ map opPair ops
96 get' (FnDef x _ _) = Left x
97 get' (OpDef op _ _ _) = Right op
98 get s = case s of Definition d -> [ get' d ]
99 Datatype _ _ tcs -> map (Left . fst) tcs
100 ImportEvent _ _ x _ -> [ Left x ]
101 ExportEvent _ _ _ -> []
102 TypeAlias _ _ _ -> []
103 TypeAnnotation _ _ -> []
106jsImport (modul, how) =
107 concat [ "\ntry{\n if (!(" ++ modul ++ " instanceof Object)) throw new Error('module not found');\n} catch(e) {\n throw new Error(\"Module '"
108 , drop 1 (dropWhile (/='.') modul)
109 , "' is missing. Compile with --make flag or load missing "
110 , "module in a separate JavaScript file.\");\n}" ] ++
111 jsImport' (modul, how)
113jsImport' (modul, As name) = assign name modul
114jsImport' (modul, Importing vs) = concatMap def vs
115 where def [] = []
116 def (o:p) | isOp o = let v = "$op['" ++ o:p ++ "']" in
117 "\n" ++ v ++ " = " ++ modul ++ "." ++ v ++ ";"
118 | otherwise = let v = deprime (o:p) in
119 assign v $ modul ++ "." ++ v
121jsImport' (modul, Hiding vs) =
122 concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
123 map (\v -> v ++ ":true") (map deprime vs)
124 , "\nfor (Elm['i'] in " ++ modul ++ ") "
125 , braces . indent . concat $
126 [ "\nif (hiddenVars[Elm['i']]) continue;"
127 , "\neval('var ' + Elm['i'] + ' = "
128 , modul, "[Elm.i];');" ]
129 ]
131stmtsToJS :: [Statement] -> String
132stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
133 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
134 valueOf s = case s of
135 Datatype _ _ _ -> 1
136 ImportEvent _ _ _ _ -> 2
137 Definition (FnDef f [] _) ->
138 if derename f == "main" then 5 else 4
139 Definition _ -> 3
140 ExportEvent _ _ _ -> 6
141 TypeAlias _ _ _ -> 0
142 TypeAnnotation _ _ -> 0
144class ToJS a where
145 toJS :: a -> GuidCounter String
147instance ToJS Def where
148 toJS (FnDef x [] e) = assign x `liftM` toJS' e
149 toJS (FnDef f (a:as) e) =
150 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
151 return $ concat ["\nfunction ",f,parens a, braces . indent $ ret body]
152 toJS (OpDef op a1 a2 e) =
153 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
154 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
156instance ToJS Statement where
157 toJS (Definition d) = toJS d
158 toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
159 where toDef (name,args) = Definition . FnDef name vars . noContext $
160 Data (derename name) (map (noContext . Var) vars)
161 where vars = map (('a':) . show) [1..length args]
162 toJS (ImportEvent js base elm _) =
163 do v <- toJS' base
164 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
165 , "\nValue.addListener(document, '" ++ js
166 , "', function(e) { Dispatcher.notify(" ++ elm
167 , ".id, e.value); });" ]
168 toJS (ExportEvent js elm _) =
169 return $ concat [ "\nlift(function(v) { "
170 , "var e = document.createEvent('Event');"
171 , "e.initEvent('", js, "', true, true);"
172 , "e.value = v;"
173 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
174 toJS (TypeAnnotation _ _) = return ""
175 toJS (TypeAlias _ _ _) = return ""
177toJS' :: CExpr -> GuidCounter String
178toJS' (C txt span expr) =
179 case expr of
180 MultiIf ps -> multiIfToJS span ps
181 Case e cases -> caseToJS span e cases
182 _ -> toJS expr
184recordToJS e loop cmds =
185 do e' <- toJS' e
186 return $ jsFunc "" (concat [ assign "r" "{}"
187 , assign "e" e'
188 , "\nfor(var i in e){", loop, "}"
189 , cmds
190 , ret "r" ]) ++ "()"
192remove x = concat [ "\n if (i!='", x, "') { r[i]=e[i]; }"
193 , "\n else if (e[i].length>1) { r[i]=e[i].slice(1); }" ]
194addField (x,e) = ((++add) . assign "v") `liftM` toJS' e
195 where add = concat [ "\n r.", x, " = '", x, "' in r ? [v].concat(r.", x, ") : [v];" ]
196setField (x,e) = let rx = "r." ++ x in
197 do set <- globalAssign (rx ++ "[0]") `liftM` toJS' e
198 return (globalAssign rx (rx ++ ".slice(0)") ++ set)
199access x e = jsFunc "r" (ret body) ++ parens e
200 where body = "'_' in r ? r." ++ x ++ "[0] : r." ++ x
201makeRecord kvs = do
202 kvs' <- (Map.toList . foldl' combine Map.empty) `liftM` mapM prep kvs
203 let fs = map (\(k,vs) -> k ++ " : " ++ jsList vs) kvs' ++ ["_ : true"]
204 return $ braces ("\n " ++ intercalate ",\n " fs)
205 where combine r (k,v) = Map.insertWith (++) k v r
206 prep (k, as, e@(C t s _)) =
207 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
208 return (k,[v])
211instance ToJS Expr where
212 toJS expr =
213 case expr of
214 IntNum n -> return $ show n
215 FloatNum n -> return $ show n
216 Var x -> return $ x
217 Chr c -> return $ quoted [c]
218 Str s -> return $ "Value.str" ++ parens (quoted s)
219 Boolean b -> return $ if b then "true" else "false"
220 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
221 Access e x -> access x `liftM` toJS' e
222 Remove e x -> recordToJS e (remove x) ""
223 Insert e x v -> recordToJS e "r[i]=e[i];" =<< addField (x,v)
224 Modify e fs -> recordToJS e "r[i]=e[i];" . concat =<< mapM setField fs
225 Record fs -> makeRecord fs
226 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
228 If eb et ef ->
229 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
231 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
233 App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
234 return $ "toText" ++ parens (quoted s)
236 App (C _ _ (Var "link")) (C _ _ (Str s)) ->
237 return $ "link(" ++ quoted s ++ ")"
239 App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
240 return $ "plainText(" ++ quoted s ++ ")"
242 App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
243 Let defs e -> jsLet defs e
244 Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
246 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
247 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
248 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
250formatMarkdown = concatMap f
251 where f '\'' = "\\'"
252 f '\n' = "\\n"
253 f '"' = "\""
254 f c = [c]
256multiIfToJS span ps = format `liftM` mapM f ps
257 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
258 err = concat [ "(function(){throw new Error(\"Non-exhaustive "
259 , "multi-way-if expression (", show span, ")\");}())" ]
260 f (b,e) = do b' <- toJS' b
261 e' <- toJS' e
262 return (b' ++ " ? " ++ e')
264jsLet defs e' = do
265 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
266 return $ jsFunc "" body ++ "()"
268jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
269 where f a b = compare (valueOf a) (valueOf b)
270 valueOf (FnDef _ args _) = min 1 (length args)
271 valueOf (OpDef _ _ _ _) = 1
273caseToJS span e ps = do
274 match <- caseToMatch ps
275 e' <- toJS' e
276 (match',stmt) <- case (match,e) of
277 (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
278 (Match name _ _, _) -> return (match, assign name e')
279 _ -> liftM (\n -> (match, e')) guid
280 matches <- matchToJS span match'
281 return $ concat [ "function(){", stmt, matches, "}()" ]
283matchToJS span (Match name clauses def) = do
284 cases <- concat `liftM` mapM (clauseToJS span name) clauses
285 finally <- matchToJS span def
286 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
287matchToJS span Fail = return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
288 "in case expression (" ++ show span ++ ")\");")
289matchToJS span Break = return "break;"
290matchToJS span (Other e) = ret `liftM` toJS' e
291matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
293clauseToJS span var (Clause name vars e) = do
294 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
295 s <- matchToJS span $ matchSubst (zip vars vars') e
296 return $ concat [ "\ncase ", quoted name, ":", s ]
298jsNil = "[\"Nil\"]"
299jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
300jsRange e1 e2 = (++"()") . jsFunc "" $
301 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
302 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
303 ret "lst"
305binop (o:p) e1 e2
306 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
307 | otherwise =
308 let ops = ["+","-","*","/","&&","||"] in
309 case o:p of
310 "::" -> jsCons e1 e2
311 "++" -> append e1 e2
312 "$" -> e1 ++ parens e2
313 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
314 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
315 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
316 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
317 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
318 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
319 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
320 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
321 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
322 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
323 "<~" -> "lift" ++ parens e1 ++ parens e2
324 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
325 parens e1 ++ parens e2
326 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
327 | otherwise -> concat [ "$op['", o:p, "']"
328 , parens e1, parens e2 ]
330append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)