git.iko.soy/elk
on 0cfae2e help sign in
elk/compiler/Generate/JavaScript.hs
383 lines 15 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,sortBy,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 Transform.SortDefinitions
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 (Module names exports imports stmts) =
56 setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
57 where
58 modNames = if null names then ["Main"] else names
59 modName = intercalate "." modNames
60 includes = concatMap jsImport imports
61 body = stmtsToJS stmts
62 defs = assign "$op" "{}"
63 program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
64 setup ("elm":"Native":modNames) ++
65 assign "_" ("elm.Native." ++ modName ++ "||{}") ++
66 getExports exports stmts ++ setup ("elm":modNames) ++
67 ret (assign' ("elm." ++ modName) "_") ++ "\n"
68 setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
69 map (intercalate ".") . drop 2 . inits $ init modNames
70 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
72getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
73 where exNames n = either derename id n `elem` names
74 exports | null names = concatMap get stmts
75 | otherwise = filter exNames (concatMap get stmts)
77 (fns,ops) = partitionEithers exports
79 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
80 fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
82 op = ("_.$op = "++) . jsObj $ map opPair ops
84 get' def =
85 case def of
86 TypeAnnotation _ _ -> []
87 Def pattern _ ->
88 case Set.toList (boundVars pattern) of
89 [var@(c:_)] -> [if isOp c then Right var else Left var]
90 vars -> map Left vars
92 get s = case s of Definition def -> get' def
93 Datatype _ _ tcs -> map (Left . fst) tcs
94 ImportEvent _ _ x _ -> [ Left x ]
95 ExportEvent _ _ _ -> []
96 TypeAlias _ _ _ -> []
99jsImport (modul, how) =
100 case how of
101 As name -> assign name ("Elm." ++ modul ++ parens "elm")
102 Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
103 "; for(var k in _){if(k in hiding)continue;" ++
104 "eval('var '+k+'=_[\"'+k+'\"]')}"
105 Importing vs -> include ++ named
106 where
107 imprt v = assign' v ("_." ++ v)
108 def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
109 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
110 where
111 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
112 setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
113 where
114 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
115 subnames = map (intercalate ".") . tail . inits . init . split
116 split names = case go [] names of
117 (name, []) -> [name]
118 (name, ns) -> name : split ns
119 go name str = case str of
120 '.':rest -> (reverse name, rest)
121 c:rest -> go (c:name) rest
122 [] -> (reverse name, [])
126stmtsToJS :: [Declaration t v] -> String
127stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
128 return (concat program)
129 where
130 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
131 valueOf s = case s of
132 Datatype _ _ _ -> 1
133 ImportEvent _ _ _ _ -> 2
134 Definition (Def f (L _ _ (Lambda _ _))) -> 3
135 Definition (Def (PVar name) _) ->
136 if derename name == "main" then 5 else 4
137 Definition (Def _ _) -> 4
138 Definition (TypeAnnotation _ _) -> 0
139 ExportEvent _ _ _ -> 6
140 TypeAlias _ _ _ -> 0
142class ToJS a where
143 toJS :: a -> Unique String
145instance ToJS (Def t v) where
147 -- TODO: Make this handle patterns besides plain variables
149 toJS (Def (PVar x) e) = assign x `liftM` toJS' e
150{--
151 toJS (Def f e) = (assign f . wrapper . func) `liftM` toJS' e
152 where
153 func body = jsFunc (intercalate ", " as) (ret body)
154 wrapper e | length as == 1 = e
155 | otherwise = 'F' : show (length as) ++ parens e
156 toJS (OpDef op a1 a2 e) =
157 do body <- toJS' e
158 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
159 return (globalAssign ("$op['" ++ op ++ "']") func)
160--}
161 toJS (TypeAnnotation _ _) = return ""
164instance ToJS (Declaration t v) where
165 toJS stmt =
166 case stmt of
167 Definition d -> toJS d
168 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
169 where toDef (name,args) =
170 let vars = map (('a':) . show) [1..length args]
171 body = Loc.none (Data (derename name) (map (Loc.none . Var) vars))
172 func = foldr (\x e -> Loc.none (Lambda (PVar x) e)) body vars
173 in Definition $ Def (PVar name) func
175 ImportEvent js base elm _ ->
176 do v <- toJS' base
177 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
178 , "\ndocument.addEventListener('", js
179 , "_' + elm.id, function(e) { elm.notify(", elm
180 , ".id, e.value); });" ]
181 ExportEvent js elm _ ->
182 return $ concat [ "\nlift(function(v) { "
183 , "var e = document.createEvent('Event');"
184 , "e.initEvent('", js, "_' + elm.id, true, true);"
185 , "e.value = v;"
186 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
187 TypeAlias n _ t -> return ""
189toJS' :: LExpr t v -> Unique String
190toJS' (L txt span expr) =
191 case expr of
192 MultiIf ps -> multiIfToJS span ps
193 Case e cases -> caseToJS span e cases
194 _ -> toJS expr
196remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
197addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
198setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
199 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
200access x e = e ++ "." ++ x
201makeRecord kvs = record `liftM` collect kvs
202 where
203 combine r (k,v) = Map.insertWith (++) k v r
204 collect = liftM (foldl' combine Map.empty) . mapM prep
205 prep (k, e) =
206 do v <- toJS' e
207 return (k,[v])
208 fields fs =
209 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
210 hidden = fields . map (second jsList) .
211 filter (not . null . snd) . Map.toList . Map.map tail
212 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
215instance ToJS Literal where
216 toJS lit =
217 case lit of
218 Chr c -> return $ quoted [c]
219 Str s -> return $ "_str" ++ parens (quoted s)
220 IntNum n -> return $ show n
221 FloatNum n -> return $ show n
222 Boolean b -> return $ if b then "true" else "false"
225instance ToJS (Expr t v) where
226 toJS expr =
227 case expr of
228 Var x -> return x
229 Literal lit -> toJS lit
230 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
231 Access e x -> access x `liftM` toJS' e
232 Remove e x -> remove x `liftM` toJS' e
233 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
234 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
235 setField fs' `liftM` toJS' e
236 Record fs -> makeRecord fs
237 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
239 Lambda p e -> liftM (jsFunc (intercalate ", " args) . ret) (toJS' body)
240 where
241 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
243 depattern (pattern,n) (args, body) =
244 case pattern of
245 PVar x -> (x:args, body)
246 _ -> let arg = "arg" ++ show n
247 in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
249 (patterns, innerBody) = collect [p] e
251 collect patterns lexpr@(L a b expr) =
252 case expr of
253 Lambda p e -> collect (p:patterns) e
254 _ -> (patterns, lexpr)
256 App e1 e2 -> jsApp e1 e2
257 Let defs e -> jsLet defs e
259 ExplicitList es ->
260 do es' <- mapM toJS' es
261 return $ "_J.toList" ++ parens (jsList es')
263 Data name es ->
264 do fs <- mapM toJS' es
265 return $ case name of
266 "[]" -> jsNil
267 "::" -> jsCons (head fs) ((head . tail) fs)
268 _ -> jsObj $ ("ctor:" ++ show name) : fields
269 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
271 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
272 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
273 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
275jsApp e1 e2 =
276 do f <- toJS' func
277 as <- mapM toJS' args
278 return $ case as of
279 [a] -> f ++ parens a
280 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
281 where
282 (func, args) = go [e2] e1
283 go args e =
284 case e of
285 (L _ _ (App e1 e2)) -> go (e2 : args) e1
286 _ -> (e, args)
288formatMarkdown = concatMap f
289 where f '\'' = "\\'"
290 f '\n' = "\\n"
291 f '"' = "\""
292 f c = [c]
294multiIfToJS span ps =
295 case last ps of
296 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
297 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
298 where
299 format base ps =
300 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
301 f (b,e) = do b' <- toJS' b
302 e' <- toJS' e
303 return (b' ++ " ? " ++ e')
305jsLet defs e' = do ds <- jsDefs defs
306 e <- toJS' e'
307 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
308 where
309 jsDefs defs = mapM toJS (sortBy f defs)
310 f a b = compare (valueOf a) (valueOf b)
311 valueOf (Def _ (L _ _ (Lambda _ _))) = 1
312 valueOf (Def _ _) = 2
313 valueOf (TypeAnnotation _ _) = 0
315caseToJS span e ps = do
316 match <- caseToMatch ps
317 e' <- toJS' e
318 let (match',stmt) = case (match,e) of
319 (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
320 (Match name _ _, _) -> (match, assign name e')
321 _ -> (match, "")
322 matches <- matchToJS span match'
323 return $ "function(){ " ++ stmt ++ matches ++ " }()"
325matchToJS span match =
326 case match of
327 Match name clauses def ->
328 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
329 finally <- matchToJS span def
330 let isLiteral p = case p of
331 Clause (Right _) _ _ -> True
332 _ -> False
333 access = if any isLiteral clauses then "" else ".ctor"
334 return $ concat [ "\nswitch (", name, access, ") {"
335 , indent cases, "\n}", finally ]
336 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
337 Break -> return "break;"
338 Other e -> ret `liftM` toJS' e
339 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
340 where
341 dropEnd acc [] = acc
342 dropEnd acc (m:ms) =
343 case m of
344 Other _ -> acc ++ [m]
345 _ -> dropEnd (acc ++ [m]) ms
347clauseToJS span var (Clause value vars e) = do
348 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
349 s <- matchToJS span $ matchSubst (zip vars vars') e
350 return $ concat [ "\ncase ", case value of
351 Left name -> quoted name
352 Right (Boolean True) -> "true"
353 Right (Boolean False) -> "false"
354 Right lit -> show lit
355 , ":", indent s ]
357jsNil = "_L.Nil"
358jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
359jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
360jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
362binop (o:p) e1 e2
363 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
364 | otherwise =
365 let ops = ["+","-","*","/","&&","||"] in
366 case o:p of
367 "::" -> jsCons e1 e2
368 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
369 "<|" -> e1 ++ parens e2
370 "|>" -> e2 ++ parens e1
371 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
372 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
373 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
374 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
375 "<" -> jsCompare e1 e2 "==='LT'"
376 ">" -> jsCompare e1 e2 "==='GT'"
377 "<=" -> jsCompare e1 e2 "!=='GT'"
378 ">=" -> jsCompare e1 e2 "!=='LT'"
379 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
380 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
381 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
382 | otherwise -> concat [ "$op['", o:p, "']"
383 , parens e1, parens e2 ]