git.iko.soy/elk
on de6cb46 help sign in
elk/elm/src/Gen/CompileToJS.hs
307 lines 13 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 Data.Map (toList)
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 \"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 'module not found';\n} catch(e) {\n throw (\"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
178instance ToJS Expr where
179 toJS expr =
180 case expr of
181 IntNum n -> return $ show n
182 FloatNum n -> return $ show n
183 Var x -> return $ x
184 Chr c -> return $ quoted [c]
185 Str s -> return $ "Value.str" ++ parens (quoted s)
186 Boolean b -> return $ if b then "true" else "false"
187 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
188 Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS' e
190 Modify e lbl v -> do e' <- toJS' e
191 v' <- toJS' v
192 let body = concat [ assign "r" e'
193 , globalAssign ("r." ++ lbl) v'
194 , ret "r" ]
195 return $ jsFunc "" body ++ "()"
197 Record fs -> (braces . intercalate ",\n") `liftM` mapM toField fs
198 where toField (f, as, ce@(C t s e)) =
199 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) ce as)
200 return (f ++ " : " ++ v)
202 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
204 If eb et ef ->
205 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
207 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
209 App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
210 return $ "toText" ++ parens (quoted s)
212 App (C _ _ (Var "link")) (C _ _ (Str s)) ->
213 return $ "link(" ++ quoted s ++ ")"
215 App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
216 return $ "plainText(" ++ quoted s ++ ")"
218 App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
219 Let defs e -> jsLet defs e
220 Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
222 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
223 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
224 md = formatMarkdown $
225 Pan.writeHtmlString Pan.defaultWriterOptions doc
227formatMarkdown = concatMap f
228 where f '\'' = "\\'"
229 f '\n' = "\\n"
230 f '"' = "\""
231 f c = [c]
233multiIfToJS span ps = format `liftM` mapM f ps
234 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
235 err = concat [ "(function(){throw \"Non-exhaustive "
236 , "multi-way-if expression (", show span, ")\";}())" ]
237 f (b,e) = do b' <- toJS' b
238 e' <- toJS' e
239 return (b' ++ " ? " ++ e')
241jsLet defs e' = do
242 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
243 return $ jsFunc "" body ++ "()"
245jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
246 where f a b = compare (valueOf a) (valueOf b)
247 valueOf (FnDef _ args _) = min 1 (length args)
248 valueOf (OpDef _ _ _ _) = 1
250caseToJS span e ps = do
251 match <- caseToMatch ps
252 e' <- toJS' e
253 (match',stmt) <- case (match,e) of
254 (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
255 (Match name _ _, _) -> return (match, assign name e')
256 _ -> liftM (\n -> (match, e')) guid
257 matches <- matchToJS span match'
258 return $ concat [ "function(){", stmt, matches, "}()" ]
260matchToJS span (Match name clauses def) = do
261 cases <- concat `liftM` mapM (clauseToJS span name) clauses
262 finally <- matchToJS span def
263 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
264matchToJS span Fail = return ("\nthrow \"Non-exhaustive pattern match " ++
265 "in case expression (" ++ show span ++ ")\";")
266matchToJS span Break = return "break;"
267matchToJS span (Other e) = ret `liftM` toJS' e
268matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
270clauseToJS span var (Clause name vars e) = do
271 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
272 s <- matchToJS span $ matchSubst (zip vars vars') e
273 return $ concat [ "\ncase ", quoted name, ":", s ]
275jsNil = "[\"Nil\"]"
276jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
277jsRange e1 e2 = (++"()") . jsFunc "" $
278 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
279 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
280 ret "lst"
282binop (o:p) e1 e2
283 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
284 | otherwise =
285 let ops = ["+","-","*","/","&&","||"] in
286 case o:p of
287 ":" -> jsCons e1 e2
288 "++" -> append e1 e2
289 "$" -> e1 ++ parens e2
290 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
291 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
292 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
293 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
294 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
295 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
296 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
297 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
298 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
299 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
300 "<~" -> "lift" ++ parens e1 ++ parens e2
301 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
302 parens e1 ++ parens e2
303 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
304 | otherwise -> concat [ "$op['", o:p, "']"
305 , parens e1, parens e2 ]
307append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)