git.iko.soy/elk
on ac450ae help sign in
elk/compiler/Generate/JavaScript.hs
342 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 qualified Data.List as List
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 ++ "}"
39commaSep = List.intercalate ", "
40dotSep = List.intercalate "."
41jsObj = brackets . commaSep
42jsList ss = "["++ List.intercalate "," ss ++"]"
43jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
44assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
45ret e = "\nreturn "++ e ++";"
46quoted s = "'" ++ concatMap f s ++ "'"
47 where f '\n' = "\\n"
48 f '\'' = "\\'"
49 f '\t' = "\\t"
50 f '\"' = "\\\""
51 f '\\' = "\\\\"
52 f c = [c]
54globalAssign n e = "\n" ++ assign' n e ++ ";"
55assign' n e = n ++ " = " ++ e
57jsModule :: MetadataModule t v -> String
58jsModule modul =
59 run $ do
60 body <- toJS . fst . SD.flattenLets [] $ program modul
61 foreignImport <- mapM importEvent (foreignImports modul)
62 return $ concat [ setup ("Elm": names modul)
63 , globalAssign ("Elm." ++ modName)
64 (jsFunc "elm" $ makeProgram body foreignImport) ]
65 where
66 modName = dotSep (names modul)
67 makeProgram body foreignImport =
68 concat [ "\nvar " ++ usefulFuncs ++ ";"
69 , assign "_op" "{}"
70 , concatMap jsImport (imports modul)
71 , concat foreignImport
72 , concatMap exportEvent $ foreignExports modul
73 , body
74 , assign "_" "{}"
75 , concatMap jsExport (exports modul)
76 , setup ("elm" : names modul)
77 , ret (assign' ("elm." ++ modName) "_")
78 ]
79 setup names = concatMap (\n -> globalAssign n $ n ++ "||{}") .
80 map dotSep . drop 2 . List.inits $ init names
81 usefulFuncs = commaSep (map (uncurry assign') internalImports)
83 jsExport x =
84 if isOp x then "\n_._op['" ++ x ++ "'] = _op['" ++ x ++ "'];"
85 else "\n_." ++ x ++ " = " ++ x ++ ";"
87 importEvent (js,base,elm,_) =
88 do v <- toJS' base
89 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
90 , "\ndocument.addEventListener('", js
91 , "_' + elm.id, function(e) { elm.notify(", elm
92 , ".id, e.value); });" ]
94 exportEvent (js,elm,_) =
95 concat [ "\nlift(function(v) { "
96 , "var e = document.createEvent('Event');"
97 , "e.initEvent('", js, "_' + elm.id, true, true);"
98 , "e.value = v;"
99 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
101jsImport (modul, how) =
102 case how of
103 As name -> assign name ("Elm." ++ modul ++ parens "elm")
104 Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
105 "; for(var k in _){if(k in hiding)continue;" ++
106 "eval('var '+k+'=_[\"'+k+'\"]')}"
107 Importing vs -> include ++ named
108 where
109 imprt v = assign' v ("_." ++ v)
110 def x = imprt $ if isOp x then "_op['" ++ x ++ "']" else deprime x
111 named = if null vs then "" else "\nvar " ++ commaSep (map def vs) ++ ";"
112 where
113 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
114 setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
115 where
116 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
117 subnames = map dotSep . tail . List.inits . init . split
118 split names = case go [] names of
119 (name, []) -> [name]
120 (name, ns) -> name : split ns
121 go name str = case str of
122 '.':rest -> (reverse name, rest)
123 c:rest -> go (c:name) rest
124 [] -> (reverse name, [])
127class ToJS a where
128 toJS :: a -> Unique String
131instance ToJS (Def t v) where
133 -- TODO: Make this handle patterns besides plain variables
134 toJS (Def (PVar x) e)
135 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
136 | otherwise = assign x `liftM` toJS' e
138 toJS (Def pattern e) =
139 do n <- guid
140 let x = "_" ++ show n
141 var = Loc.none . Var
142 toDef y = Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
143 stmt <- assign x `liftM` toJS' e
144 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
145 return (stmt ++ vars)
147 toJS (TypeAnnotation _ _) = return ""
150instance ToJS a => ToJS [a] where
151 toJS xs = concat `liftM` mapM toJS xs
153toJS' :: LExpr t v -> Unique String
154toJS' (L txt span expr) =
155 case expr of
156 MultiIf ps -> multiIfToJS span ps
157 Case e cases -> caseToJS span e cases
158 _ -> toJS expr
160remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
161addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
162setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
163 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
164access x e = e ++ "." ++ x
165makeRecord kvs = record `liftM` collect kvs
166 where
167 combine r (k,v) = Map.insertWith (++) k v r
168 collect = liftM (List.foldl' combine Map.empty) . mapM prep
169 prep (k, e) =
170 do v <- toJS' e
171 return (k,[v])
172 fields fs =
173 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
174 hidden = fields . map (second jsList) .
175 filter (not . null . snd) . Map.toList . Map.map tail
176 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
179instance ToJS Literal where
180 toJS lit =
181 case lit of
182 Chr c -> return $ quoted [c]
183 Str s -> return $ "_str" ++ parens (quoted s)
184 IntNum n -> return $ show n
185 FloatNum n -> return $ show n
186 Boolean b -> return $ if b then "true" else "false"
189instance ToJS (Expr t v) where
190 toJS expr =
191 case expr of
192 Var x -> return x
193 Literal lit -> toJS lit
194 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
195 Access e x -> access x `liftM` toJS' e
196 Remove e x -> remove x `liftM` toJS' e
197 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
198 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
199 setField fs' `liftM` toJS' e
200 Record fs -> makeRecord fs
201 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
203 Lambda p e -> liftM (jsFunc (commaSep args) . ret) (toJS' body)
204 where
205 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
207 depattern (pattern,n) (args, body) =
208 case pattern of
209 PVar x -> (x:args, body)
210 _ -> let arg = "arg" ++ show n
211 in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
213 (patterns, innerBody) = collect [p] e
215 collect patterns lexpr@(L a b expr) =
216 case expr of
217 Lambda p e -> collect (p:patterns) e
218 _ -> (patterns, lexpr)
220 App e1 e2 -> jsApp e1 e2
221 Let defs e -> jsLet $ SD.flattenLets defs e
223 ExplicitList es ->
224 do es' <- mapM toJS' es
225 return $ "_J.toList" ++ parens (jsList es')
227 Data name es ->
228 do fs <- mapM toJS' es
229 return $ case name of
230 "[]" -> jsNil
231 "::" -> jsCons (head fs) ((head . tail) fs)
232 _ -> jsObj $ ("ctor:" ++ show name) : fields
233 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
235 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
236 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
237 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
239jsApp e1 e2 =
240 do f <- toJS' func
241 as <- mapM toJS' args
242 return $ case as of
243 [a] -> f ++ parens a
244 _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
245 where
246 (func, args) = go [e2] e1
247 go args e =
248 case e of
249 (L _ _ (App e1 e2)) -> go (e2 : args) e1
250 _ -> (e, args)
252formatMarkdown = concatMap f
253 where f '\'' = "\\'"
254 f '\n' = "\\n"
255 f '"' = "\""
256 f c = [c]
258multiIfToJS span ps =
259 case last ps of
260 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
261 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
262 where
263 format base ps =
264 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
265 f (b,e) = do b' <- toJS' b
266 e' <- toJS' e
267 return (b' ++ " ? " ++ e')
269jsLet (defs,e') = do ds <- mapM toJS defs
270 e <- toJS' e'
271 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
273caseToJS span e ps = do
274 match <- caseToMatch ps
275 e' <- toJS' e
276 let (match',stmt) = case (match,e) of
277 (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
278 (Match name _ _, _) -> (match, assign name e')
279 _ -> (match, "")
280 matches <- matchToJS span match'
281 return $ "function(){ " ++ stmt ++ matches ++ " }()"
283matchToJS span match =
284 case match of
285 Match name clauses def ->
286 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
287 finally <- matchToJS span def
288 let isLiteral p = case p of
289 Clause (Right _) _ _ -> True
290 _ -> False
291 access = if any isLiteral clauses then "" else ".ctor"
292 return $ concat [ "\nswitch (", name, access, ") {"
293 , indent cases, "\n}", finally ]
294 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
295 Break -> return "break;"
296 Other e -> ret `liftM` toJS' e
297 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
298 where
299 dropEnd acc [] = acc
300 dropEnd acc (m:ms) =
301 case m of
302 Other _ -> acc ++ [m]
303 _ -> dropEnd (acc ++ [m]) ms
305clauseToJS span var (Clause value vars e) = do
306 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
307 s <- matchToJS span $ matchSubst (zip vars vars') e
308 return $ concat [ "\ncase ", case value of
309 Left name -> quoted name
310 Right (Boolean True) -> "true"
311 Right (Boolean False) -> "false"
312 Right lit -> show lit
313 , ":", indent s ]
315jsNil = "_L.Nil"
316jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
317jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
318jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
320-- todo: this is incorrect. Operators come in prefixed by their module now.
321binop (o:p) e1 e2
322 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
323 | otherwise =
324 let ops = ["+","-","*","/","&&","||"] in
325 case o:p of
326 "::" -> jsCons e1 e2
327 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
328 "<|" -> e1 ++ parens e2
329 "|>" -> e2 ++ parens e1
330 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
331 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
332 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
333 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
334 "<" -> jsCompare e1 e2 "==='LT'"
335 ">" -> jsCompare e1 e2 "==='GT'"
336 "<=" -> jsCompare e1 e2 "!=='GT'"
337 ">=" -> jsCompare e1 e2 "!=='LT'"
338 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
339 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
340 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
341 | otherwise -> concat [ "_op['", o:p, "']"
342 , parens e1, parens e2 ]