git.iko.soy/elk
on 32efcfa help sign in
elk/elm/src/Gen/CompileToJS.hs
323 lines 14 kB history raw
1module CompileToJS (showErr, jsModule) where
3import Ast
4import Context
5import Control.Arrow (first,second)
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 _ _ _ -> []
102 TypeAlias _ _ _ -> []
103 TypeAnnotation _ _ -> []
106jsImport (modul, how) =
107 concat [ "\ntry{\n if (!(" ++ modul ++ " instanceof Object)) throw new Error('module not found');\n} catch(e) {\n throw new Error(\"Module '"
108 , drop 1 (dropWhile (/='.') modul)
109 , "' is missing. Compile with --make flag or load missing "
110 , "module in a separate JavaScript file.\");\n}" ] ++
111 jsImport' (modul, how)
113jsImport' (modul, As name) = assign name modul
114jsImport' (modul, Importing vs) = concatMap def vs
115 where def [] = []
116 def (o:p) | isOp o = let v = "$op['" ++ o:p ++ "']" in
117 "\n" ++ v ++ " = " ++ modul ++ "." ++ v ++ ";"
118 | otherwise = let v = deprime (o:p) in
119 assign v $ modul ++ "." ++ v
121jsImport' (modul, Hiding vs) =
122 concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
123 map (\v -> v ++ ":true") (map deprime vs)
124 , "\nfor (Elm['i'] in " ++ modul ++ ") "
125 , braces . indent . concat $
126 [ "\nif (hiddenVars[Elm['i']]) continue;"
127 , "\neval('var ' + Elm['i'] + ' = "
128 , modul, "[Elm.i];');" ]
129 ]
131stmtsToJS :: [Statement] -> String
132stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
133 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
134 valueOf s = case s of
135 Datatype _ _ _ -> 1
136 ImportEvent _ _ _ _ -> 2
137 Definition (FnDef f [] _) ->
138 if derename f == "main" then 5 else 4
139 Definition _ -> 3
140 ExportEvent _ _ _ -> 6
141 TypeAlias _ _ _ -> 0
142 TypeAnnotation _ _ -> 0
144class ToJS a where
145 toJS :: a -> GuidCounter String
147instance ToJS Def where
148 toJS (FnDef x [] e) = assign x `liftM` toJS' e
149 toJS (FnDef f (a:as) e) =
150 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
151 return $ concat ["\nfunction ",f,parens a, braces . indent $ ret body]
152 toJS (OpDef op a1 a2 e) =
153 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
154 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
156instance ToJS Statement where
157 toJS (Definition d) = toJS d
158 toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
159 where toDef (name,args) = Definition . FnDef name vars . noContext $
160 Data (derename name) (map (noContext . Var) vars)
161 where vars = map (('a':) . show) [1..length args]
162 toJS (ImportEvent js base elm _) =
163 do v <- toJS' base
164 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
165 , "\nValue.addListener(document, '" ++ js
166 , "', function(e) { Dispatcher.notify(" ++ elm
167 , ".id, e.value); });" ]
168 toJS (ExportEvent js elm _) =
169 return $ concat [ "\nlift(function(v) { "
170 , "var e = document.createEvent('Event');"
171 , "e.initEvent('", js, "', true, true);"
172 , "e.value = v;"
173 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
174 toJS (TypeAnnotation _ _) = return ""
175 toJS (TypeAlias _ _ _) = return ""
177toJS' :: CExpr -> GuidCounter String
178toJS' (C txt span expr) =
179 case expr of
180 MultiIf ps -> multiIfToJS span ps
181 Case e cases -> caseToJS span e cases
182 _ -> toJS expr
184remove x e = "elmRecordRemove('" ++ x ++ "', " ++ e ++ ")"
185addField x v e = "elmRecordInsert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
186setField fs e = "elmRecordReplace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
187 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
188access x e = parens e ++ "." ++ x
189makeRecord kvs = record `liftM` collect kvs
190 where
191 combine r (k,v) = Map.insertWith (++) k v r
192 collect = liftM (foldl' combine Map.empty) . mapM prep
193 prep (k, as, e@(C t s _)) =
194 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
195 return (k,[v])
196 fields fs =
197 braces ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
198 hidden = fields . map (second jsList) .
199 filter (not . null . snd) . Map.toList . Map.map tail
200 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
203instance ToJS Expr where
204 toJS expr =
205 case expr of
206 IntNum n -> return $ show n
207 FloatNum n -> return $ show n
208 Var x -> return $ x
209 Chr c -> return $ quoted [c]
210 Str s -> return $ "Value.str" ++ parens (quoted s)
211 Boolean b -> return $ if b then "true" else "false"
212 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
213 Access e x -> access x `liftM` toJS' e
214 Remove e x -> remove x `liftM` toJS' e
215 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
216 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
217 setField fs' `liftM` toJS' e
218 Record fs -> makeRecord fs
219 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
221 If eb et ef ->
222 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
224 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
226 App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
227 return $ "toText" ++ parens (quoted s)
229 App (C _ _ (Var "link")) (C _ _ (Str s)) ->
230 return $ "link(" ++ quoted s ++ ")"
232 App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
233 return $ "plainText(" ++ quoted s ++ ")"
235 App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
236 Let defs e -> jsLet defs e
237 Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
239 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
240 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
241 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
243formatMarkdown = concatMap f
244 where f '\'' = "\\'"
245 f '\n' = "\\n"
246 f '"' = "\""
247 f c = [c]
249multiIfToJS span ps = format `liftM` mapM f ps
250 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
251 err = concat [ "(function(){throw new Error(\"Non-exhaustive "
252 , "multi-way-if expression (", show span, ")\");}())" ]
253 f (b,e) = do b' <- toJS' b
254 e' <- toJS' e
255 return (b' ++ " ? " ++ e')
257jsLet defs e' = do
258 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
259 return $ jsFunc "" body ++ "()"
261jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
262 where f a b = compare (valueOf a) (valueOf b)
263 valueOf (FnDef _ args _) = min 1 (length args)
264 valueOf (OpDef _ _ _ _) = 1
266caseToJS span e ps = do
267 match <- caseToMatch ps
268 e' <- toJS' e
269 (match',stmt) <- case (match,e) of
270 (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
271 (Match name _ _, _) -> return (match, assign name e')
272 _ -> liftM (\n -> (match, e')) guid
273 matches <- matchToJS span match'
274 return $ concat [ "function(){", stmt, matches, "}()" ]
276matchToJS span (Match name clauses def) = do
277 cases <- concat `liftM` mapM (clauseToJS span name) clauses
278 finally <- matchToJS span def
279 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
280matchToJS span Fail = return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
281 "in case expression (" ++ show span ++ ")\");")
282matchToJS span Break = return "break;"
283matchToJS span (Other e) = ret `liftM` toJS' e
284matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
286clauseToJS span var (Clause name vars e) = do
287 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
288 s <- matchToJS span $ matchSubst (zip vars vars') e
289 return $ concat [ "\ncase ", quoted name, ":", s ]
291jsNil = "[\"Nil\"]"
292jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
293jsRange e1 e2 = (++"()") . jsFunc "" $
294 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
295 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
296 ret "lst"
298binop (o:p) e1 e2
299 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
300 | otherwise =
301 let ops = ["+","-","*","/","&&","||"] in
302 case o:p of
303 "::" -> jsCons e1 e2
304 "++" -> append e1 e2
305 "$" -> e1 ++ parens e2
306 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
307 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
308 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
309 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
310 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
311 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
312 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
313 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
314 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
315 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
316 "<~" -> "lift" ++ parens e1 ++ parens e2
317 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
318 parens e1 ++ parens e2
319 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
320 | otherwise -> concat [ "$op['", o:p, "']"
321 , parens e1, parens e2 ]
323append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)