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