git.iko.soy/elk
on 2eeac2f help sign in
elk/elm/src/Gen/CompileToJS.hs
264 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
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 Guard ps -> guardToJS ps
177 Lambda v e -> liftM (jsFunc v . ret) (toJS e)
178 App (Var "toText") (Str s) -> return $ "toText" ++ parens (show s)
179 App (Var "link") (Str s) -> return $ "link(" ++ show s ++ ")"
180 App (Var "plainText") (Str s) -> return $ "plainText(" ++ show s ++ ")"
181 App e1 e2 -> (++) `liftM` (toJS e1) `ap` (parens `liftM` toJS e2)
182 Let defs e -> jsLet defs e
183 Case e cases -> caseToJS e cases
184 Data name es -> (\ss -> jsList $ show name : ss) `liftM` mapM toJS es
185 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
186 where md = formatMarkdown $ Pan.writeHtmlString Pan.defaultWriterOptions doc
187 pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
189formatMarkdown = concatMap f
190 where f '\'' = "\\'"
191 f '\n' = "\\n"
192 f '"' = "\""
193 f c = [c]
195guardToJS ps = format `liftM` mapM f ps
196 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
197 err = "(function(){throw \"Non-exhaustive guard expression\";}())"
198 f (b,e) = do b' <- toJS b
199 e' <- toJS e
200 return (b' ++ " ? " ++ e')
202jsLet defs e' = do
203 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')
204 return $ jsFunc "" body ++ "()"
206jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
207 where f a b = compare (valueOf a) (valueOf b)
208 valueOf (FnDef _ args _) = min 1 (length args)
209 valueOf (OpDef _ _ _ _) = 1
211caseToJS e ps = do
212 match <- caseToMatch ps
213 e' <- toJS e
214 (match',stmt) <- case (match,e) of
215 (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")
216 (Match name _ _, _ ) -> return (match, assign name e')
217 _ -> liftM (\n -> (match, e')) guid
218 matches <- matchToJS match'
219 return $ concat [ "function(){", stmt, matches, "}()" ]
221matchToJS (Match name clauses def) = do
222 cases <- concat `liftM` mapM (clauseToJS name) clauses
223 finally <- matchToJS def
224 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
225matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
226matchToJS Break = return "break;"
227matchToJS (Other e) = ret `liftM` toJS e
228matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms
230clauseToJS var (Clause name vars e) = do
231 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
232 s <- matchToJS $ matchSubst (zip vars vars') e
233 return $ concat [ "\ncase ", show name, ":", s ]
235jsNil = "[\"Nil\"]"
236jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
237jsRange e1 e2 = (++"()") . jsFunc "" $
238 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
239 "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
240 ret "lst"
242binop (o:p) e1 e2
243 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
244 | otherwise =
245 let ops = ["+","-","*","/","&&","||"] in
246 case o:p of
247 ":" -> jsCons e1 e2
248 "++" -> append e1 e2
249 "$" -> e1 ++ parens e2
250 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
251 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
252 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
253 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
254 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
255 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
256 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
257 e2 ++ ")[0]; return ord==='LT' || ord==='EQ'; }()"
258 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
259 e2 ++ ")[0]; return ord==='GT' || ord==='EQ'; }()"
260 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
261 | otherwise -> concat [ "$op['", o:p, "']"
262 , parens e1, parens e2 ]
264append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)