git.iko.soy/elk
on 5cc99f5 help sign in
elk/compiler/Generate/JavaScript.hs
384 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
17import Types.Types ( Type(RecordT) )
19showErr :: String -> String
20showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
21 where msg = show . concatMap (++"<br>") . lines $ err
22 body = "var T = Elm.Text(elm);\n\
23 \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
25indent = concatMap f
26 where f '\n' = "\n "
27 f c = [c]
29internalImports =
30 [ ("N" , "Elm.Native"),
31 ("_N", "N.Utils(elm)"),
32 ("_L", "N.List(elm)"),
33 ("_E", "N.Error(elm)"),
34 ("_J", "N.JavaScript(elm)"),
35 ("_str", "_J.toString")
36 ]
38parens s = "(" ++ s ++ ")"
39brackets s = "{" ++ s ++ "}"
40jsObj = brackets . intercalate ", "
41jsList ss = "["++ intercalate "," ss ++"]"
42jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
43assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
44ret e = "\nreturn "++ e ++";"
45quoted s = "'" ++ concatMap f s ++ "'"
46 where f '\n' = "\\n"
47 f '\'' = "\\'"
48 f '\t' = "\\t"
49 f '\"' = "\\\""
50 f '\\' = "\\\\"
51 f c = [c]
53globalAssign n e = "\n" ++ assign' n e ++ ";"
54assign' n e = n ++ " = " ++ e
56jsModule (Module names exports imports stmts) =
57 setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
58 where
59 modNames = if null names then ["Main"] else names
60 modName = intercalate "." modNames
61 includes = concatMap jsImport imports
62 body = stmtsToJS stmts
63 defs = assign "$op" "{}"
64 program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
65 setup ("elm":"Native":modNames) ++
66 assign "_" ("elm.Native." ++ modName ++ "||{}") ++
67 getExports exports stmts ++ setup ("elm":modNames) ++
68 ret (assign' ("elm." ++ modName) "_") ++ "\n"
69 setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
70 map (intercalate ".") . drop 2 . inits $ init modNames
71 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
73getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
74 where exNames n = either derename id n `elem` names
75 exports | null names = concatMap get stmts
76 | otherwise = filter exNames (concatMap get stmts)
78 (fns,ops) = partitionEithers exports
80 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
81 fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
83 op = ("_.$op = "++) . jsObj $ map opPair ops
85 get' def =
86 case def of
87 TypeAnnotation _ _ -> []
88 Def pattern _ ->
89 case Set.toList (boundVars pattern) of
90 [var@(c:_)] -> [if isOp c then Right var else Left var]
91 vars -> map Left vars
93 get s = case s of Definition def -> get' def
94 Datatype _ _ tcs -> map (Left . fst) tcs
95 ImportEvent _ _ x _ -> [ Left x ]
96 ExportEvent _ _ _ -> []
97 TypeAlias _ _ _ -> []
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 (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
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, [])
127stmtsToJS :: [Declaration t v] -> String
128stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
129 return (concat program)
130 where
131 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
132 valueOf s = case s of
133 Datatype _ _ _ -> 1
134 ImportEvent _ _ _ _ -> 2
135 Definition (Def f (L _ _ (Lambda _ _))) -> 3
136 Definition (Def (PVar name) _) ->
137 if derename name == "main" then 5 else 4
138 Definition (Def _ _) -> 4
139 Definition (TypeAnnotation _ _) -> 0
140 ExportEvent _ _ _ -> 6
141 TypeAlias _ _ _ -> 0
143class ToJS a where
144 toJS :: a -> Unique String
146instance ToJS (Def t v) where
148 -- TODO: Make this handle patterns besides plain variables
150 toJS (Def (PVar x) e) = assign x `liftM` toJS' e
151{--
152 toJS (Def f e) = (assign f . wrapper . func) `liftM` toJS' e
153 where
154 func body = jsFunc (intercalate ", " as) (ret body)
155 wrapper e | length as == 1 = e
156 | otherwise = 'F' : show (length as) ++ parens e
157 toJS (OpDef op a1 a2 e) =
158 do body <- toJS' e
159 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
160 return (globalAssign ("$op['" ++ op ++ "']") func)
161--}
162 toJS (TypeAnnotation _ _) = return ""
165instance ToJS (Declaration t v) where
166 toJS stmt =
167 case stmt of
168 Definition d -> toJS d
169 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
170 where toDef (name,args) =
171 let vars = map (('a':) . show) [1..length args]
172 body = Loc.none (Data (derename name) (map (Loc.none . Var) vars))
173 func = foldr (\x e -> Loc.none (Lambda (PVar x) e)) body vars
174 in Definition $ Def (PVar name) func
176 ImportEvent js base elm _ ->
177 do v <- toJS' base
178 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
179 , "\ndocument.addEventListener('", js
180 , "_' + elm.id, function(e) { elm.notify(", elm
181 , ".id, e.value); });" ]
182 ExportEvent js elm _ ->
183 return $ concat [ "\nlift(function(v) { "
184 , "var e = document.createEvent('Event');"
185 , "e.initEvent('", js, "_' + elm.id, true, true);"
186 , "e.value = v;"
187 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
188 TypeAlias n _ t -> return ""
190toJS' :: LExpr t v -> Unique String
191toJS' (L txt span expr) =
192 case expr of
193 MultiIf ps -> multiIfToJS span ps
194 Case e cases -> caseToJS span e cases
195 _ -> toJS expr
197remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
198addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
199setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
200 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
201access x e = e ++ "." ++ x
202makeRecord kvs = record `liftM` collect kvs
203 where
204 combine r (k,v) = Map.insertWith (++) k v r
205 collect = liftM (foldl' combine Map.empty) . mapM prep
206 prep (k, e) =
207 do v <- toJS' e
208 return (k,[v])
209 fields fs =
210 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
211 hidden = fields . map (second jsList) .
212 filter (not . null . snd) . Map.toList . Map.map tail
213 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
216instance ToJS Literal where
217 toJS lit =
218 case lit of
219 Chr c -> return $ quoted [c]
220 Str s -> return $ "_str" ++ parens (quoted s)
221 IntNum n -> return $ show n
222 FloatNum n -> return $ show n
223 Boolean b -> return $ if b then "true" else "false"
226instance ToJS (Expr t v) where
227 toJS expr =
228 case expr of
229 Var x -> return x
230 Literal lit -> toJS lit
231 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
232 Access e x -> access x `liftM` toJS' e
233 Remove e x -> remove x `liftM` toJS' e
234 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
235 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
236 setField fs' `liftM` toJS' e
237 Record fs -> makeRecord fs
238 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
240 Lambda p e -> liftM (jsFunc (intercalate ", " args) . ret) (toJS' body)
241 where
242 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
244 depattern (pattern,n) (args, body) =
245 case pattern of
246 PVar x -> (x:args, body)
247 _ -> let arg = "arg" ++ show n
248 in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
250 (patterns, innerBody) = collect [p] e
252 collect patterns lexpr@(L a b expr) =
253 case expr of
254 Lambda p e -> collect (p:patterns) e
255 _ -> (patterns, lexpr)
257 App e1 e2 -> jsApp e1 e2
258 Let defs e -> jsLet defs e
260 ExplicitList es ->
261 do es' <- mapM toJS' es
262 return $ "_J.toList" ++ parens (jsList es')
264 Data name es ->
265 do fs <- mapM toJS' es
266 return $ case name of
267 "[]" -> jsNil
268 "::" -> jsCons (head fs) ((head . tail) fs)
269 _ -> jsObj $ ("ctor:" ++ show name) : fields
270 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
272 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
273 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
274 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
276jsApp e1 e2 =
277 do f <- toJS' func
278 as <- mapM toJS' args
279 return $ case as of
280 [a] -> f ++ parens a
281 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
282 where
283 (func, args) = go [e2] e1
284 go args e =
285 case e of
286 (L _ _ (App e1 e2)) -> go (e2 : args) e1
287 _ -> (e, args)
289formatMarkdown = concatMap f
290 where f '\'' = "\\'"
291 f '\n' = "\\n"
292 f '"' = "\""
293 f c = [c]
295multiIfToJS span ps =
296 case last ps of
297 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
298 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
299 where
300 format base ps =
301 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
302 f (b,e) = do b' <- toJS' b
303 e' <- toJS' e
304 return (b' ++ " ? " ++ e')
306jsLet defs e' = do ds <- jsDefs defs
307 e <- toJS' e'
308 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
309 where
310 jsDefs defs = mapM toJS (sortBy f defs)
311 f a b = compare (valueOf a) (valueOf b)
312 valueOf (Def _ (L _ _ (Lambda _ _))) = 1
313 valueOf (Def _ _) = 2
314 valueOf (TypeAnnotation _ _) = 0
316caseToJS span e ps = do
317 match <- caseToMatch ps
318 e' <- toJS' e
319 let (match',stmt) = case (match,e) of
320 (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
321 (Match name _ _, _) -> (match, assign name e')
322 _ -> (match, "")
323 matches <- matchToJS span match'
324 return $ "function(){ " ++ stmt ++ matches ++ " }()"
326matchToJS span match =
327 case match of
328 Match name clauses def ->
329 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
330 finally <- matchToJS span def
331 let isLiteral p = case p of
332 Clause (Right _) _ _ -> True
333 _ -> False
334 access = if any isLiteral clauses then "" else ".ctor"
335 return $ concat [ "\nswitch (", name, access, ") {"
336 , indent cases, "\n}", finally ]
337 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
338 Break -> return "break;"
339 Other e -> ret `liftM` toJS' e
340 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
341 where
342 dropEnd acc [] = acc
343 dropEnd acc (m:ms) =
344 case m of
345 Other _ -> acc ++ [m]
346 _ -> dropEnd (acc ++ [m]) ms
348clauseToJS span var (Clause value vars e) = do
349 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
350 s <- matchToJS span $ matchSubst (zip vars vars') e
351 return $ concat [ "\ncase ", case value of
352 Left name -> quoted name
353 Right (Boolean True) -> "true"
354 Right (Boolean False) -> "false"
355 Right lit -> show lit
356 , ":", indent s ]
358jsNil = "_L.Nil"
359jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
360jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
361jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
363binop (o:p) e1 e2
364 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
365 | otherwise =
366 let ops = ["+","-","*","/","&&","||"] in
367 case o:p of
368 "::" -> jsCons e1 e2
369 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
370 "<|" -> e1 ++ parens e2
371 "|>" -> e2 ++ parens e1
372 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
373 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
374 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
375 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
376 "<" -> jsCompare e1 e2 "==='LT'"
377 ">" -> jsCompare e1 e2 "==='GT'"
378 "<=" -> jsCompare e1 e2 "!=='GT'"
379 ">=" -> jsCompare e1 e2 "!=='LT'"
380 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
381 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
382 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
383 | otherwise -> concat [ "$op['", o:p, "']"
384 , parens e1, parens e2 ]