git.iko.soy/elk
on ec94f4e help sign in
elk/elm/src/Gen/CompileToJS.hs
300 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 Record fs -> (braces . intercalate ",\n") `liftM` mapM toField fs
191 where toField (f, as, ce@(C t s e)) =
192 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) ce as)
193 return (f ++ " : " ++ v)
195 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
197 If eb et ef ->
198 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
200 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
202 App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
203 return $ "toText" ++ parens (quoted s)
205 App (C _ _ (Var "link")) (C _ _ (Str s)) ->
206 return $ "link(" ++ quoted s ++ ")"
208 App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
209 return $ "plainText(" ++ quoted s ++ ")"
211 App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
212 Let defs e -> jsLet defs e
213 Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
215 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
216 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
217 md = formatMarkdown $
218 Pan.writeHtmlString Pan.defaultWriterOptions doc
220formatMarkdown = concatMap f
221 where f '\'' = "\\'"
222 f '\n' = "\\n"
223 f '"' = "\""
224 f c = [c]
226multiIfToJS span ps = format `liftM` mapM f ps
227 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
228 err = concat [ "(function(){throw \"Non-exhaustive "
229 , "multi-way-if expression (", show span, ")\";}())" ]
230 f (b,e) = do b' <- toJS' b
231 e' <- toJS' e
232 return (b' ++ " ? " ++ e')
234jsLet defs e' = do
235 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
236 return $ jsFunc "" body ++ "()"
238jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
239 where f a b = compare (valueOf a) (valueOf b)
240 valueOf (FnDef _ args _) = min 1 (length args)
241 valueOf (OpDef _ _ _ _) = 1
243caseToJS span e ps = do
244 match <- caseToMatch ps
245 e' <- toJS' e
246 (match',stmt) <- case (match,e) of
247 (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
248 (Match name _ _, _) -> return (match, assign name e')
249 _ -> liftM (\n -> (match, e')) guid
250 matches <- matchToJS span match'
251 return $ concat [ "function(){", stmt, matches, "}()" ]
253matchToJS span (Match name clauses def) = do
254 cases <- concat `liftM` mapM (clauseToJS span name) clauses
255 finally <- matchToJS span def
256 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
257matchToJS span Fail = return ("\nthrow \"Non-exhaustive pattern match " ++
258 "in case expression (" ++ show span ++ ")\";")
259matchToJS span Break = return "break;"
260matchToJS span (Other e) = ret `liftM` toJS' e
261matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
263clauseToJS span var (Clause name vars e) = do
264 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
265 s <- matchToJS span $ matchSubst (zip vars vars') e
266 return $ concat [ "\ncase ", quoted name, ":", s ]
268jsNil = "[\"Nil\"]"
269jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
270jsRange e1 e2 = (++"()") . jsFunc "" $
271 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
272 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
273 ret "lst"
275binop (o:p) e1 e2
276 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
277 | otherwise =
278 let ops = ["+","-","*","/","&&","||"] in
279 case o:p of
280 ":" -> jsCons e1 e2
281 "++" -> append e1 e2
282 "$" -> e1 ++ parens e2
283 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
284 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
285 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
286 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
287 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
288 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
289 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
290 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
291 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
292 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
293 "<~" -> "lift" ++ parens e1 ++ parens e2
294 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
295 parens e1 ++ parens e2
296 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
297 | otherwise -> concat [ "$op['", o:p, "']"
298 , parens e1, parens e2 ]
300append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)