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