git.iko.soy/elk
on 64e88fd help sign in
elk/elm/src/Gen/CompileToJS.hs
272 lines 12 kB history raw
2module CompileToJS (showErr, jsModule) where
4import Ast
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 Lambda 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 Lambda 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) =
156 Definition . FnDef name vars $ Data (derename name) (map 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, ");" ]
171instance ToJS Expr where
172 toJS expr =
173 case expr of
174 IntNum n -> return $ show n
175 FloatNum n -> return $ show n
176 Var x -> return $ x
177 Chr c -> return $ quoted [c]
178 Str s -> return $ "Value.str" ++ parens (quoted s)
179 Boolean b -> return $ if b then "true" else "false"
180 Range lo hi -> jsRange `liftM` toJS lo `ap` toJS hi
181 Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS e
182 Binop op e1 e2 -> binop op `liftM` toJS e1 `ap` toJS e2
183 If eb et ef -> parens `liftM` (iff `liftM` toJS eb `ap` toJS et `ap` toJS ef)
184 Guard ps -> guardToJS ps
185 Lambda v e -> liftM (jsFunc v . ret) (toJS e)
186 App (Var "toText") (Str s) -> return $ "toText" ++ parens (quoted s)
187 App (Var "link") (Str s) -> return $ "link(" ++ quoted s ++ ")"
188 App (Var "plainText") (Str s) -> return $ "plainText(" ++ quoted s ++ ")"
189 App e1 e2 -> (++) `liftM` (toJS e1) `ap` (parens `liftM` toJS e2)
190 Let defs e -> jsLet defs e
191 Case e cases -> caseToJS e cases
192 Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS es
193 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
194 where md = formatMarkdown $ Pan.writeHtmlString Pan.defaultWriterOptions doc
195 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
197formatMarkdown = concatMap f
198 where f '\'' = "\\'"
199 f '\n' = "\\n"
200 f '"' = "\""
201 f c = [c]
203guardToJS ps = format `liftM` mapM f ps
204 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
205 err = "(function(){throw \"Non-exhaustive guard expression\";}())"
206 f (b,e) = do b' <- toJS b
207 e' <- toJS e
208 return (b' ++ " ? " ++ e')
210jsLet defs e' = do
211 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')
212 return $ jsFunc "" body ++ "()"
214jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
215 where f a b = compare (valueOf a) (valueOf b)
216 valueOf (FnDef _ args _) = min 1 (length args)
217 valueOf (OpDef _ _ _ _) = 1
219caseToJS e ps = do
220 match <- caseToMatch ps
221 e' <- toJS e
222 (match',stmt) <- case (match,e) of
223 (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")
224 (Match name _ _, _ ) -> return (match, assign name e')
225 _ -> liftM (\n -> (match, e')) guid
226 matches <- matchToJS match'
227 return $ concat [ "function(){", stmt, matches, "}()" ]
229matchToJS (Match name clauses def) = do
230 cases <- concat `liftM` mapM (clauseToJS name) clauses
231 finally <- matchToJS def
232 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
233matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
234matchToJS Break = return "break;"
235matchToJS (Other e) = ret `liftM` toJS e
236matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms
238clauseToJS var (Clause name vars e) = do
239 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
240 s <- matchToJS $ matchSubst (zip vars vars') e
241 return $ concat [ "\ncase ", quoted name, ":", s ]
243jsNil = "[\"Nil\"]"
244jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
245jsRange e1 e2 = (++"()") . jsFunc "" $
246 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
247 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
248 ret "lst"
250binop (o:p) e1 e2
251 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
252 | otherwise =
253 let ops = ["+","-","*","/","&&","||"] in
254 case o:p of
255 ":" -> jsCons e1 e2
256 "++" -> append e1 e2
257 "$" -> e1 ++ parens e2
258 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
259 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
260 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
261 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
262 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
263 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
264 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
265 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
266 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
267 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
268 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
269 | otherwise -> concat [ "$op['", o:p, "']"
270 , parens e1, parens e2 ]
272append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)