git.iko.soy/elk
on 5dadeee help sign in
elk/elm/src/Gen/CompileToJS.hs
324 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" "{}"
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 [ "\n r.", x, " = '", x, "' in r ? [v].concat(r.", x, ") : [v];" ]
190setField (x,e) = let rx = "r." ++ x in
191 do set <- globalAssign (rx ++ "[0]") `liftM` toJS' e
192 return (globalAssign rx (rx ++ ".slice(0)") ++ set)
193access x e = jsFunc "r" (ret body) ++ parens e
194 where body = "'_' in r ? r." ++ x ++ "[0] : r." ++ x
195makeRecord kvs = do
196 kvs' <- (Map.toList . foldl' combine Map.empty) `liftM` mapM prep kvs
197 let fs = map (\(k,vs) -> k ++ " : " ++ jsList vs) kvs' ++ ["_ : true"]
198 return $ braces ("\n " ++ intercalate ",\n " fs)
199 where combine r (k,v) = Map.insertWith (++) k v r
200 prep (k, as, e@(C t s _)) =
201 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
202 return (k,[v])
205instance ToJS Expr where
206 toJS expr =
207 case expr of
208 IntNum n -> return $ show n
209 FloatNum n -> return $ show n
210 Var x -> return $ x
211 Chr c -> return $ quoted [c]
212 Str s -> return $ "Value.str" ++ parens (quoted s)
213 Boolean b -> return $ if b then "true" else "false"
214 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
215 Access e x -> access x `liftM` toJS' e
216 Remove e x -> recordToJS e (remove x) ""
217 Insert e x v -> recordToJS e "r[i]=e[i];" =<< addField (x,v)
218 Modify e fs -> recordToJS e "r[i]=e[i];" . concat =<< mapM setField fs
219 Record fs -> makeRecord fs
220 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
222 If eb et ef ->
223 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
225 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
227 App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
228 return $ "toText" ++ parens (quoted s)
230 App (C _ _ (Var "link")) (C _ _ (Str s)) ->
231 return $ "link(" ++ quoted s ++ ")"
233 App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
234 return $ "plainText(" ++ quoted s ++ ")"
236 App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
237 Let defs e -> jsLet defs e
238 Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
240 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
241 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
242 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
244formatMarkdown = concatMap f
245 where f '\'' = "\\'"
246 f '\n' = "\\n"
247 f '"' = "\""
248 f c = [c]
250multiIfToJS span ps = format `liftM` mapM f ps
251 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
252 err = concat [ "(function(){throw new Error(\"Non-exhaustive "
253 , "multi-way-if expression (", show span, ")\");}())" ]
254 f (b,e) = do b' <- toJS' b
255 e' <- toJS' e
256 return (b' ++ " ? " ++ e')
258jsLet defs e' = do
259 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
260 return $ jsFunc "" body ++ "()"
262jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
263 where f a b = compare (valueOf a) (valueOf b)
264 valueOf (FnDef _ args _) = min 1 (length args)
265 valueOf (OpDef _ _ _ _) = 1
267caseToJS span e ps = do
268 match <- caseToMatch ps
269 e' <- toJS' e
270 (match',stmt) <- case (match,e) of
271 (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
272 (Match name _ _, _) -> return (match, assign name e')
273 _ -> liftM (\n -> (match, e')) guid
274 matches <- matchToJS span match'
275 return $ concat [ "function(){", stmt, matches, "}()" ]
277matchToJS span (Match name clauses def) = do
278 cases <- concat `liftM` mapM (clauseToJS span name) clauses
279 finally <- matchToJS span def
280 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
281matchToJS span Fail = return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
282 "in case expression (" ++ show span ++ ")\");")
283matchToJS span Break = return "break;"
284matchToJS span (Other e) = ret `liftM` toJS' e
285matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
287clauseToJS span var (Clause name vars e) = do
288 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
289 s <- matchToJS span $ matchSubst (zip vars vars') e
290 return $ concat [ "\ncase ", quoted name, ":", s ]
292jsNil = "[\"Nil\"]"
293jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
294jsRange e1 e2 = (++"()") . jsFunc "" $
295 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
296 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
297 ret "lst"
299binop (o:p) e1 e2
300 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
301 | otherwise =
302 let ops = ["+","-","*","/","&&","||"] in
303 case o:p of
304 ":" -> jsCons e1 e2
305 "++" -> append e1 e2
306 "$" -> e1 ++ parens e2
307 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
308 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
309 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
310 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
311 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
312 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
313 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
314 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
315 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
316 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
317 "<~" -> "lift" ++ parens e1 ++ parens e2
318 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
319 parens e1 ++ parens e2
320 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
321 | otherwise -> concat [ "$op['", o:p, "']"
322 , parens e1, parens e2 ]
324append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)