git.iko.soy/elk
on db7e617 help sign in
elk/elm/src/Gen/CompileToJS.hs
327 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 _ _ _ -> []
104jsImport (modul, how) =
105 concat [ "\ntry{\n if (!(" ++ modul ++ " instanceof Object)) throw new Error('module not found');\n} catch(e) {\n throw new Error(\"Module '"
106 , drop 1 (dropWhile (/='.') modul)
107 , "' is missing. Compile with --make flag or load missing "
108 , "module in a separate JavaScript file.\");\n}" ] ++
109 jsImport' (modul, how)
111jsImport' (modul, As name) = assign name modul
112jsImport' (modul, Importing vs) = concatMap def vs
113 where def [] = []
114 def (o:p) | isOp o = let v = "$op['" ++ o:p ++ "']" in
115 "\n" ++ v ++ " = " ++ modul ++ "." ++ v ++ ";"
116 | otherwise = let v = deprime (o:p) in
117 assign v $ modul ++ "." ++ v
119jsImport' (modul, Hiding vs) =
120 concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
121 map (\v -> v ++ ":true") (map deprime vs)
122 , "\nfor (Elm['i'] in " ++ modul ++ ") "
123 , braces . indent . concat $
124 [ "\nif (hiddenVars[Elm['i']]) continue;"
125 , "\neval('var ' + Elm['i'] + ' = "
126 , modul, "[Elm.i];');" ]
127 ]
129stmtsToJS :: [Statement] -> String
130stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
131 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
132 valueOf s = case s of
133 Datatype _ _ _ -> 1
134 ImportEvent _ _ _ _ -> 2
135 Definition (FnDef f [] _) ->
136 if derename f == "main" then 5 else 4
137 Definition _ -> 3
138 ExportEvent _ _ _ -> 6
140class ToJS a where
141 toJS :: a -> GuidCounter String
143instance ToJS Def where
144 toJS (FnDef x [] e) = assign x `liftM` toJS' e
145 toJS (FnDef f (a:as) e) =
146 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
147 return $ concat ["\nfunction ",f,parens a, braces . indent $ ret body]
148 toJS (OpDef op a1 a2 e) =
149 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
150 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
152instance ToJS Statement where
153 toJS (Definition d) = toJS d
154 toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
155 where toDef (name,args) = Definition . FnDef name vars . noContext $
156 Data (derename name) (map (noContext . Var) vars)
157 where vars = map (('a':) . show) [1..length args]
158 toJS (ImportEvent js base elm _) =
159 do v <- toJS' base
160 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
161 , "\nValue.addListener(document, '" ++ js
162 , "', function(e) { Dispatcher.notify(" ++ elm
163 , ".id, e.value); });" ]
164 toJS (ExportEvent js elm _) =
165 return $ concat [ "\nlift(function(v) { "
166 , "var e = document.createEvent('Event');"
167 , "e.initEvent('", js, "', true, true);"
168 , "e.value = v;"
169 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
171toJS' :: CExpr -> GuidCounter String
172toJS' (C txt span expr) =
173 case expr of
174 MultiIf ps -> multiIfToJS span ps
175 Case e cases -> caseToJS span e cases
176 _ -> toJS expr
178recordToJS e loop cmds =
179 do e' <- toJS' e
180 return $ jsFunc "" (concat [ assign "r" "{_:[true]}"
181 , assign "e" e'
182 , "\nfor(var i in e){", loop, "}"
183 , cmds
184 , ret "r" ]) ++ "()"
186remove x = concat [ "\n if (i!='", x, "') { r[i]=e[i]; }"
187 , "\n else if (e[i].length>1) { r[i]=e[i].slice(1); }" ]
188addField (x,e) = ((++add) . assign "v") `liftM` toJS' e
189 where add = concat [ "\nif (r.hasOwnProperty('", x, "')) {"
190 , "\n r.", x, " = r.", x, ".slice(0);"
191 , "\n r.", x, ".unshift(v);"
192 , "\n} else { r.", x, " = [v]; }" ]
193setField (x,e) = do
194 set <- globalAssign ("r." ++ x ++ "[0]") `liftM` toJS' e
195 return (globalAssign ("r." ++ x) ("r." ++ x ++ ".slice(0)") ++ set)
196access x e = jsFunc "r" (ret body) ++ parens e
197 where body = "r.hasOwnProperty('_') ? r." ++ x ++ "[0] : r." ++ x
198makeRecord kvs = do
199 kvs' <- (Map.toList . foldl' combine Map.empty) `liftM` mapM prep kvs
200 let fs = map (\(k,vs) -> k ++ " : " ++ jsList vs) kvs' ++ ["_ : [true]"]
201 return $ braces ("\n " ++ intercalate ",\n " fs)
202 where combine r (k,v) = Map.insertWith (++) k v r
203 prep (k, as, e@(C t s _)) =
204 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
205 return (k,[v])
208instance ToJS Expr where
209 toJS expr =
210 case expr of
211 IntNum n -> return $ show n
212 FloatNum n -> return $ show n
213 Var x -> return $ x
214 Chr c -> return $ quoted [c]
215 Str s -> return $ "Value.str" ++ parens (quoted s)
216 Boolean b -> return $ if b then "true" else "false"
217 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
218 Access e x -> access x `liftM` toJS' e
219 Remove e x -> recordToJS e (remove x) ""
220 Insert e x v -> recordToJS e "r[i]=e[i];" =<< addField (x,v)
221 Modify e fs -> recordToJS e "r[i]=e[i];" . concat =<< mapM setField fs
222 Record fs -> makeRecord fs
223 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
225 If eb et ef ->
226 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
228 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
230 App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
231 return $ "toText" ++ parens (quoted s)
233 App (C _ _ (Var "link")) (C _ _ (Str s)) ->
234 return $ "link(" ++ quoted s ++ ")"
236 App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
237 return $ "plainText(" ++ quoted s ++ ")"
239 App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
240 Let defs e -> jsLet defs e
241 Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
243 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
244 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
245 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
247formatMarkdown = concatMap f
248 where f '\'' = "\\'"
249 f '\n' = "\\n"
250 f '"' = "\""
251 f c = [c]
253multiIfToJS span ps = format `liftM` mapM f ps
254 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
255 err = concat [ "(function(){throw new Error(\"Non-exhaustive "
256 , "multi-way-if expression (", show span, ")\");}())" ]
257 f (b,e) = do b' <- toJS' b
258 e' <- toJS' e
259 return (b' ++ " ? " ++ e')
261jsLet defs e' = do
262 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
263 return $ jsFunc "" body ++ "()"
265jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
266 where f a b = compare (valueOf a) (valueOf b)
267 valueOf (FnDef _ args _) = min 1 (length args)
268 valueOf (OpDef _ _ _ _) = 1
270caseToJS span e ps = do
271 match <- caseToMatch ps
272 e' <- toJS' e
273 (match',stmt) <- case (match,e) of
274 (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
275 (Match name _ _, _) -> return (match, assign name e')
276 _ -> liftM (\n -> (match, e')) guid
277 matches <- matchToJS span match'
278 return $ concat [ "function(){", stmt, matches, "}()" ]
280matchToJS span (Match name clauses def) = do
281 cases <- concat `liftM` mapM (clauseToJS span name) clauses
282 finally <- matchToJS span def
283 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
284matchToJS span Fail = return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
285 "in case expression (" ++ show span ++ ")\");")
286matchToJS span Break = return "break;"
287matchToJS span (Other e) = ret `liftM` toJS' e
288matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
290clauseToJS span var (Clause name vars e) = do
291 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
292 s <- matchToJS span $ matchSubst (zip vars vars') e
293 return $ concat [ "\ncase ", quoted name, ":", s ]
295jsNil = "[\"Nil\"]"
296jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
297jsRange e1 e2 = (++"()") . jsFunc "" $
298 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
299 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
300 ret "lst"
302binop (o:p) e1 e2
303 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
304 | otherwise =
305 let ops = ["+","-","*","/","&&","||"] in
306 case o:p of
307 ":" -> jsCons e1 e2
308 "++" -> append e1 e2
309 "$" -> e1 ++ parens e2
310 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
311 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
312 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
313 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
314 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
315 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
316 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
317 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
318 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
319 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
320 "<~" -> "lift" ++ parens e1 ++ parens e2
321 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
322 parens e1 ++ parens e2
323 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
324 | otherwise -> concat [ "$op['", o:p, "']"
325 , parens e1, parens e2 ]
327append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)