git.iko.soy/elk
on 3bb618b help sign in
elk/compiler/Generate/JavaScript.hs
340 lines 13 kB history raw
1module Generate.JavaScript (showErr, jsModule) where
3import Control.Arrow (first,second)
4import Control.Monad (liftM,(<=<),join,ap)
5import Data.Char (isAlpha,isDigit)
6import Data.List (intercalate,inits,foldl')
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import Data.Either (partitionEithers)
10import qualified Text.Pandoc as Pan
12import Unique
13import Generate.Cases
14import SourceSyntax.Everything hiding (parens)
15import SourceSyntax.Location as Loc
16import qualified Transform.SortDefinitions as SD
18showErr :: String -> String
19showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
20 where msg = show . concatMap (++"<br>") . lines $ err
21 body = "var T = Elm.Text(elm);\n\
22 \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
24indent = concatMap f
25 where f '\n' = "\n "
26 f c = [c]
28internalImports =
29 [ ("N" , "Elm.Native"),
30 ("_N", "N.Utils(elm)"),
31 ("_L", "N.List(elm)"),
32 ("_E", "N.Error(elm)"),
33 ("_J", "N.JavaScript(elm)"),
34 ("_str", "_J.toString")
35 ]
37parens s = "(" ++ s ++ ")"
38brackets s = "{" ++ s ++ "}"
39jsObj = brackets . intercalate ", "
40jsList ss = "["++ intercalate "," ss ++"]"
41jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
42assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
43ret e = "\nreturn "++ e ++";"
44quoted s = "'" ++ concatMap f s ++ "'"
45 where f '\n' = "\\n"
46 f '\'' = "\\'"
47 f '\t' = "\\t"
48 f '\"' = "\\\""
49 f '\\' = "\\\\"
50 f c = [c]
52globalAssign n e = "\n" ++ assign' n e ++ ";"
53assign' n e = n ++ " = " ++ e
55jsModule :: MetadataModule t v -> String
56jsModule modul =
57 run $ do
58 body <- toJS (defs modul)
59 foreignImport <- mapM importEvent (foreignImports modul)
60 return $ concat [ setup ("Elm": names modul)
61 , globalAssign ("Elm." ++ modName)
62 (jsFunc "elm" $ program body foreignImport) ]
63 where
64 modName = intercalate "." (names modul)
65 program body foreignImport =
66 concat [ "\nvar " ++ usefulFuncs ++ ";"
67 , assign "_op" "{}"
68 , concatMap jsImport (imports modul)
69 , concat foreignImport
70 , concatMap exportEvent $ foreignExports modul
71 , body
72 , setup ("elm" : "Native" : names modul)
73 , assign "_" ("elm.Native." ++ modName ++ "||{}")
74 , concatMap jsExport (exports modul)
75 , setup ("elm" : names modul)
76 , ret (assign' ("elm." ++ modName) "_")
77 ]
78 setup names = concatMap (\n -> globalAssign n $ n ++ "||{}") .
79 map (intercalate ".") . drop 2 . inits $ init names
80 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
82 jsExport x =
83 if isOp x then "\n_._op['" ++ x ++ "'] = _op['" ++ x ++ "'];"
84 else "\n_." ++ derename x ++ " = " ++ x ++ ";"
86 importEvent (js,base,elm,_) =
87 do v <- toJS' base
88 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
89 , "\ndocument.addEventListener('", js
90 , "_' + elm.id, function(e) { elm.notify(", elm
91 , ".id, e.value); });" ]
93 exportEvent (js,elm,_) =
94 concat [ "\nlift(function(v) { "
95 , "var e = document.createEvent('Event');"
96 , "e.initEvent('", js, "_' + elm.id, true, true);"
97 , "e.value = v;"
98 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
100jsImport (modul, how) =
101 case how of
102 As name -> assign name ("Elm." ++ modul ++ parens "elm")
103 Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
104 "; for(var k in _){if(k in hiding)continue;" ++
105 "eval('var '+k+'=_[\"'+k+'\"]')}"
106 Importing vs -> include ++ named
107 where
108 imprt v = assign' v ("_." ++ v)
109 def x = imprt $ if isOp x then "_op['" ++ x ++ "']" else deprime x
110 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
111 where
112 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
113 setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
114 where
115 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
116 subnames = map (intercalate ".") . tail . inits . init . split
117 split names = case go [] names of
118 (name, []) -> [name]
119 (name, ns) -> name : split ns
120 go name str = case str of
121 '.':rest -> (reverse name, rest)
122 c:rest -> go (c:name) rest
123 [] -> (reverse name, [])
126class ToJS a where
127 toJS :: a -> Unique String
130instance ToJS (Def t v) where
132 -- TODO: Make this handle patterns besides plain variables
133 toJS (Def (PVar x) e)
134 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
135 | otherwise = assign x `liftM` toJS' e
137 toJS (Def pattern e) =
138 do n <- guid
139 let x = "_" ++ show n
140 var = Loc.none . Var
141 toDef y = Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
142 stmt <- assign x `liftM` toJS' e
143 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
144 return (stmt ++ vars)
146 toJS (TypeAnnotation _ _) = return ""
149instance ToJS a => ToJS [a] where
150 toJS xs = concat `liftM` mapM toJS xs
152toJS' :: LExpr t v -> Unique String
153toJS' (L txt span expr) =
154 case expr of
155 MultiIf ps -> multiIfToJS span ps
156 Case e cases -> caseToJS span e cases
157 _ -> toJS expr
159remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
160addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
161setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
162 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
163access x e = e ++ "." ++ x
164makeRecord kvs = record `liftM` collect kvs
165 where
166 combine r (k,v) = Map.insertWith (++) k v r
167 collect = liftM (foldl' combine Map.empty) . mapM prep
168 prep (k, e) =
169 do v <- toJS' e
170 return (k,[v])
171 fields fs =
172 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
173 hidden = fields . map (second jsList) .
174 filter (not . null . snd) . Map.toList . Map.map tail
175 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
178instance ToJS Literal where
179 toJS lit =
180 case lit of
181 Chr c -> return $ quoted [c]
182 Str s -> return $ "_str" ++ parens (quoted s)
183 IntNum n -> return $ show n
184 FloatNum n -> return $ show n
185 Boolean b -> return $ if b then "true" else "false"
188instance ToJS (Expr t v) where
189 toJS expr =
190 case expr of
191 Var x -> return x
192 Literal lit -> toJS lit
193 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
194 Access e x -> access x `liftM` toJS' e
195 Remove e x -> remove x `liftM` toJS' e
196 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
197 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
198 setField fs' `liftM` toJS' e
199 Record fs -> makeRecord fs
200 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
202 Lambda p e -> liftM (jsFunc (intercalate ", " args) . ret) (toJS' body)
203 where
204 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
206 depattern (pattern,n) (args, body) =
207 case pattern of
208 PVar x -> (x:args, body)
209 _ -> let arg = "arg" ++ show n
210 in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
212 (patterns, innerBody) = collect [p] e
214 collect patterns lexpr@(L a b expr) =
215 case expr of
216 Lambda p e -> collect (p:patterns) e
217 _ -> (patterns, lexpr)
219 App e1 e2 -> jsApp e1 e2
220 Let defs e -> jsLet $ SD.flattenLets defs e
222 ExplicitList es ->
223 do es' <- mapM toJS' es
224 return $ "_J.toList" ++ parens (jsList es')
226 Data name es ->
227 do fs <- mapM toJS' es
228 return $ case name of
229 "[]" -> jsNil
230 "::" -> jsCons (head fs) ((head . tail) fs)
231 _ -> jsObj $ ("ctor:" ++ show name) : fields
232 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
234 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
235 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
236 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
238jsApp e1 e2 =
239 do f <- toJS' func
240 as <- mapM toJS' args
241 return $ case as of
242 [a] -> f ++ parens a
243 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
244 where
245 (func, args) = go [e2] e1
246 go args e =
247 case e of
248 (L _ _ (App e1 e2)) -> go (e2 : args) e1
249 _ -> (e, args)
251formatMarkdown = concatMap f
252 where f '\'' = "\\'"
253 f '\n' = "\\n"
254 f '"' = "\""
255 f c = [c]
257multiIfToJS span ps =
258 case last ps of
259 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
260 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
261 where
262 format base ps =
263 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
264 f (b,e) = do b' <- toJS' b
265 e' <- toJS' e
266 return (b' ++ " ? " ++ e')
268jsLet (defs,e') = do ds <- mapM toJS defs
269 e <- toJS' e'
270 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
272caseToJS span e ps = do
273 match <- caseToMatch ps
274 e' <- toJS' e
275 let (match',stmt) = case (match,e) of
276 (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
277 (Match name _ _, _) -> (match, assign name e')
278 _ -> (match, "")
279 matches <- matchToJS span match'
280 return $ "function(){ " ++ stmt ++ matches ++ " }()"
282matchToJS span match =
283 case match of
284 Match name clauses def ->
285 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
286 finally <- matchToJS span def
287 let isLiteral p = case p of
288 Clause (Right _) _ _ -> True
289 _ -> False
290 access = if any isLiteral clauses then "" else ".ctor"
291 return $ concat [ "\nswitch (", name, access, ") {"
292 , indent cases, "\n}", finally ]
293 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
294 Break -> return "break;"
295 Other e -> ret `liftM` toJS' e
296 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
297 where
298 dropEnd acc [] = acc
299 dropEnd acc (m:ms) =
300 case m of
301 Other _ -> acc ++ [m]
302 _ -> dropEnd (acc ++ [m]) ms
304clauseToJS span var (Clause value vars e) = do
305 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
306 s <- matchToJS span $ matchSubst (zip vars vars') e
307 return $ concat [ "\ncase ", case value of
308 Left name -> quoted name
309 Right (Boolean True) -> "true"
310 Right (Boolean False) -> "false"
311 Right lit -> show lit
312 , ":", indent s ]
314jsNil = "_L.Nil"
315jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
316jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
317jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
319binop (o:p) e1 e2
320 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
321 | otherwise =
322 let ops = ["+","-","*","/","&&","||"] in
323 case o:p of
324 "::" -> jsCons e1 e2
325 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
326 "<|" -> e1 ++ parens e2
327 "|>" -> e2 ++ parens e1
328 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
329 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
330 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
331 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
332 "<" -> jsCompare e1 e2 "==='LT'"
333 ">" -> jsCompare e1 e2 "==='GT'"
334 "<=" -> jsCompare e1 e2 "!=='GT'"
335 ">=" -> jsCompare e1 e2 "!=='LT'"
336 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
337 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
338 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
339 | otherwise -> concat [ "_op['", o:p, "']"
340 , parens e1, parens e2 ]