git.iko.soy/elk
on c2acf71 help sign in
elk/elm/src/Gen/CompileToJS.hs
274 lines 12 kB history raw
1module CompileToJS (showErr, jsModule) where
3import Ast
4import Control.Arrow (first)
5import Control.Monad (liftM,(<=<),join,ap)
6import Data.Char (isAlpha,isDigit)
7import Data.List (intercalate,sortBy,inits,foldl')
8import Data.Map (toList)
9import Data.Either (partitionEithers)
10import qualified Text.Pandoc as Pan
12import Initialize
13import Rename (derename)
14import Cases
15import Guid
16import Parse.Library (isOp)
17import Rename (deprime)
19showErr :: String -> String
20showErr err = mainEquals $ "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
21 where msg = show . concatMap (++"<br>") . lines $ err
23indent = concatMap f
24 where f '\n' = "\n "
25 f c = [c]
27parens s = "(" ++ s ++ ")"
28braces s = "{" ++ s ++ "}"
29jsList ss = "["++ intercalate "," ss ++"]"
30jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
31assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
32ret e = "\nreturn "++ e ++";"
33iff a b c = a ++ "?" ++ b ++ ":" ++ c
34quoted s = "'" ++ concatMap f s ++ "'"
35 where f '\n' = "\\n"
36 f '\'' = "\\'"
37 f '\t' = "\\t"
38 f '\"' = "\\\""
39 f '\\' = "\\\\"
40 f c = [c]
42mainEquals s = globalAssign "Elm.main" (jsFunc "" (ret s))
43globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
45tryBlock escapees names e =
46 concat [ "\ntry{\n" ++ e ++ "\n} catch (e) {"
47 , "\nElm.main=function() {"
48 , "\nvar msg = ('<br/><h2>Your browser may not be supported. " ++
49 "Are you using a modern browser?</h2>' +" ++
50 " '<br/><span style=\"color:grey\">Runtime Error in " ++
51 intercalate "." names ++ " module:<br/>' + e + '" ++ msg ++ "</span>');"
52 , "\ndocument.body.innerHTML = Elm.Text.monospace(msg);"
53 , "throw e;"
54 , "};}"
55 ]
56 where msg | escapees /= [] = concat [ "<br/><br/>The problem may stem from an improper usage of:<br/>"
57 , intercalate ", " $ map (concatMap escape) escapees ]
58 | otherwise = ""
59 escape '\'' = "\\'"
60 escape '"' = "\\\""
61 escape c = [c]
64jsModule (escapees, Module names exports imports stmts) =
65 tryBlock escapees (tail modNames) $ concat
66 [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
67 map (intercalate ".") . drop 2 . inits $
68 take (length modNames - 1) modNames
69 , "\nif (" ++ modName ++ ") throw \"Module name collision, '" ++
70 intercalate "." (tail modNames) ++ "' is already defined.\"; "
71 , globalAssign modName $ jsFunc "" (defs ++ includes ++ body ++ export) ++ "()"
72 , mainEquals $ modName ++ ".main" ]
73 where modNames = if null names then ["Elm", "Main"]
74 else "Elm" : names
75 modName = intercalate "." modNames
76 includes = concatMap jsImport $ map (first ("Elm."++)) imports
77 body = stmtsToJS stmts
78 export = getExports exports stmts
79 exps = if null exports then ["main"] else exports
80 defs = concat [ assign "$op" "{}"
81 , "\nfor(Elm['i'] in Elm){eval('var '+Elm['i']+'=Elm[Elm.i];');}" ]
83getExports names stmts = ret . braces $ intercalate ",\n" (op : map fnPair fns)
84 where exNames n = either derename id n `elem` names
85 exports | null names = concatMap get stmts
86 | otherwise = filter exNames (concatMap get stmts)
88 (fns,ops) = partitionEithers exports
90 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
91 fnPair fn = let fn' = derename fn in fn' ++ ":" ++ fn
93 op = ("$op : "++) . braces . intercalate ", " $ map opPair ops
95 get' (FnDef x _ _) = Left x
96 get' (OpDef op _ _ _) = Right op
97 get s = case s of Definition d -> [ get' d ]
98 Datatype _ _ tcs -> map (Left . fst) tcs
99 ImportEvent _ _ x _ -> [ Left x ]
100 ExportEvent _ _ _ -> []
103jsImport (modul, how) =
104 concat [ "\ntry{\n if (!(" ++ modul ++ " instanceof Object)) throw 'module not found';\n} catch(e) {\n throw (\"Module '"
105 , drop 1 (dropWhile (/='.') modul)
106 , "' is missing. Compile with --make flag or load missing "
107 , "module in a separate JavaScript file.\");\n}" ] ++
108 jsImport' (modul, how)
110jsImport' (modul, As name) = assign name modul
111jsImport' (modul, Importing vs) = concatMap def vs
112 where def [] = []
113 def (o:p) | isOp o = let v = "$op['" ++ o:p ++ "']" in
114 "\n" ++ v ++ " = " ++ modul ++ "." ++ v ++ ";"
115 | otherwise = let v = deprime (o:p) in
116 assign v $ modul ++ "." ++ v
118jsImport' (modul, Hiding vs) =
119 concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
120 map (\v -> v ++ ":true") (map deprime vs)
121 , "\nfor (Elm['i'] in " ++ modul ++ ") "
122 , braces . indent . concat $
123 [ "\nif (hiddenVars[Elm['i']]) continue;"
124 , "\neval('var ' + Elm['i'] + ' = "
125 , modul, "[Elm.i];');" ]
126 ]
128stmtsToJS :: [Statement] -> String
129stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
130 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
131 valueOf s = case s of
132 Datatype _ _ _ -> 1
133 ImportEvent _ _ _ _ -> 2
134 Definition (FnDef f [] _) ->
135 if derename f == "main" then 5 else 4
136 Definition _ -> 3
137 ExportEvent _ _ _ -> 6
139class ToJS a where
140 toJS :: a -> GuidCounter String
142instance ToJS Def where
143 toJS (FnDef x [] e) = assign x `liftM` toJS e
144 toJS (FnDef f (a:as) e) =
145 do body <- toJS (foldr Lambda e as)
146 return $ concat ["\nfunction ",f,parens a, braces . indent $ ret body]
147 toJS (OpDef op a1 a2 e) =
148 do body <- toJS (foldr Lambda e [a1,a2])
149 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
151instance ToJS Statement where
152 toJS (Definition d) = toJS d
153 toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
154 where toDef (name,args) =
155 Definition . FnDef name vars $ Data (derename name) (map Var vars)
156 where vars = map (('a':) . show) [1..length args]
157 toJS (ImportEvent js base elm _) =
158 do v <- toJS base
159 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
160 , "\nValue.addListener(document, '" ++ js
161 , "', function(e) { Dispatcher.notify(" ++ elm
162 , ".id, e.value); });" ]
163 toJS (ExportEvent js elm _) =
164 return $ concat [ "\nlift(function(v) { "
165 , "var e = document.createEvent('Event');"
166 , "e.initEvent('", js, "', true, true);"
167 , "e.value = v;"
168 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
170instance ToJS Expr where
171 toJS expr =
172 case expr of
173 IntNum n -> return $ show n
174 FloatNum n -> return $ show n
175 Var x -> return $ x
176 Chr c -> return $ quoted [c]
177 Str s -> return $ "Value.str" ++ parens (quoted s)
178 Boolean b -> return $ if b then "true" else "false"
179 Range lo hi -> jsRange `liftM` toJS lo `ap` toJS hi
180 Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS e
181 Binop op e1 e2 -> binop op `liftM` toJS e1 `ap` toJS e2
182 If eb et ef -> parens `liftM` (iff `liftM` toJS eb `ap` toJS et `ap` toJS ef)
183 Guard ps -> guardToJS ps
184 Lambda v e -> liftM (jsFunc v . ret) (toJS e)
185 App (Var "toText") (Str s) -> return $ "toText" ++ parens (quoted s)
186 App (Var "link") (Str s) -> return $ "link(" ++ quoted s ++ ")"
187 App (Var "plainText") (Str s) -> return $ "plainText(" ++ quoted s ++ ")"
188 App e1 e2 -> (++) `liftM` (toJS e1) `ap` (parens `liftM` toJS e2)
189 Let defs e -> jsLet defs e
190 Case e cases -> caseToJS e cases
191 Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS es
192 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
193 where md = formatMarkdown $ Pan.writeHtmlString Pan.defaultWriterOptions doc
194 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
196formatMarkdown = concatMap f
197 where f '\'' = "\\'"
198 f '\n' = "\\n"
199 f '"' = "\""
200 f c = [c]
202guardToJS ps = format `liftM` mapM f ps
203 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
204 err = "(function(){throw \"Non-exhaustive guard expression\";}())"
205 f (b,e) = do b' <- toJS b
206 e' <- toJS e
207 return (b' ++ " ? " ++ e')
209jsLet defs e' = do
210 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')
211 return $ jsFunc "" body ++ "()"
213jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
214 where f a b = compare (valueOf a) (valueOf b)
215 valueOf (FnDef _ args _) = min 1 (length args)
216 valueOf (OpDef _ _ _ _) = 1
218caseToJS e ps = do
219 match <- caseToMatch ps
220 e' <- toJS e
221 (match',stmt) <- case (match,e) of
222 (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")
223 (Match name _ _, _ ) -> return (match, assign name e')
224 _ -> liftM (\n -> (match, e')) guid
225 matches <- matchToJS match'
226 return $ concat [ "function(){", stmt, matches, "}()" ]
228matchToJS (Match name clauses def) = do
229 cases <- concat `liftM` mapM (clauseToJS name) clauses
230 finally <- matchToJS def
231 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
232matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
233matchToJS Break = return "break;"
234matchToJS (Other e) = ret `liftM` toJS e
235matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms
237clauseToJS var (Clause name vars e) = do
238 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
239 s <- matchToJS $ matchSubst (zip vars vars') e
240 return $ concat [ "\ncase ", quoted name, ":", s ]
242jsNil = "[\"Nil\"]"
243jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
244jsRange e1 e2 = (++"()") . jsFunc "" $
245 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
246 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
247 ret "lst"
249binop (o:p) e1 e2
250 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
251 | otherwise =
252 let ops = ["+","-","*","/","&&","||"] in
253 case o:p of
254 ":" -> jsCons e1 e2
255 "++" -> append e1 e2
256 "$" -> e1 ++ parens e2
257 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
258 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
259 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
260 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
261 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
262 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
263 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
264 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
265 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
266 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
267 "<~" -> "lift" ++ parens e1 ++ parens e2
268 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
269 parens e1 ++ parens e2
270 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
271 | otherwise -> concat [ "$op['", o:p, "']"
272 , parens e1, parens e2 ]
274append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)