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