git.iko.soy/elk
on d2bc280 help sign in
elk/elm/src/Gen/CompileToJS.hs
328 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 $
246 Pan.writeHtmlString Pan.defaultWriterOptions doc
248formatMarkdown = concatMap f
249 where f '\'' = "\\'"
250 f '\n' = "\\n"
251 f '"' = "\""
252 f c = [c]
254multiIfToJS span ps = format `liftM` mapM f ps
255 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
256 err = concat [ "(function(){throw new Error(\"Non-exhaustive "
257 , "multi-way-if expression (", show span, ")\");}())" ]
258 f (b,e) = do b' <- toJS' b
259 e' <- toJS' e
260 return (b' ++ " ? " ++ e')
262jsLet defs e' = do
263 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
264 return $ jsFunc "" body ++ "()"
266jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
267 where f a b = compare (valueOf a) (valueOf b)
268 valueOf (FnDef _ args _) = min 1 (length args)
269 valueOf (OpDef _ _ _ _) = 1
271caseToJS span e ps = do
272 match <- caseToMatch ps
273 e' <- toJS' e
274 (match',stmt) <- case (match,e) of
275 (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
276 (Match name _ _, _) -> return (match, assign name e')
277 _ -> liftM (\n -> (match, e')) guid
278 matches <- matchToJS span match'
279 return $ concat [ "function(){", stmt, matches, "}()" ]
281matchToJS span (Match name clauses def) = do
282 cases <- concat `liftM` mapM (clauseToJS span name) clauses
283 finally <- matchToJS span def
284 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
285matchToJS span Fail = return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
286 "in case expression (" ++ show span ++ ")\");")
287matchToJS span Break = return "break;"
288matchToJS span (Other e) = ret `liftM` toJS' e
289matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
291clauseToJS span var (Clause name vars e) = do
292 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
293 s <- matchToJS span $ matchSubst (zip vars vars') e
294 return $ concat [ "\ncase ", quoted name, ":", s ]
296jsNil = "[\"Nil\"]"
297jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
298jsRange e1 e2 = (++"()") . jsFunc "" $
299 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
300 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
301 ret "lst"
303binop (o:p) e1 e2
304 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
305 | otherwise =
306 let ops = ["+","-","*","/","&&","||"] in
307 case o:p of
308 ":" -> jsCons e1 e2
309 "++" -> append e1 e2
310 "$" -> e1 ++ parens e2
311 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
312 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
313 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
314 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
315 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
316 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
317 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
318 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
319 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
320 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
321 "<~" -> "lift" ++ parens e1 ++ parens e2
322 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
323 parens e1 ++ parens e2
324 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
325 | otherwise -> concat [ "$op['", o:p, "']"
326 , parens e1, parens e2 ]
328append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)