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