git.iko.soy/elk
on d6acea8 help sign in
elk/compiler/Generate/JavaScript.hs
339 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 . fst . SD.flattenLets [] $ program modul
59 foreignImport <- mapM importEvent (foreignImports modul)
60 return $ concat [ setup ("Elm": names modul)
61 , globalAssign ("Elm." ++ modName)
62 (jsFunc "elm" $ makeProgram body foreignImport) ]
63 where
64 modName = intercalate "." (names modul)
65 makeProgram 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 , assign "_" "{}"
73 , concatMap jsExport (exports modul)
74 , setup ("elm" : names modul)
75 , ret (assign' ("elm." ++ modName) "_")
76 ]
77 setup names = concatMap (\n -> globalAssign n $ n ++ "||{}") .
78 map (intercalate ".") . drop 2 . inits $ init names
79 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
81 jsExport x =
82 if isOp x then "\n_._op['" ++ x ++ "'] = _op['" ++ x ++ "'];"
83 else "\n_." ++ derename x ++ " = " ++ x ++ ";"
85 importEvent (js,base,elm,_) =
86 do v <- toJS' base
87 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
88 , "\ndocument.addEventListener('", js
89 , "_' + elm.id, function(e) { elm.notify(", elm
90 , ".id, e.value); });" ]
92 exportEvent (js,elm,_) =
93 concat [ "\nlift(function(v) { "
94 , "var e = document.createEvent('Event');"
95 , "e.initEvent('", js, "_' + elm.id, true, true);"
96 , "e.value = v;"
97 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
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 x = imprt $ if isOp x then "_op['" ++ x ++ "']" else deprime x
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, [])
125class ToJS a where
126 toJS :: a -> Unique String
129instance ToJS (Def t v) where
131 -- TODO: Make this handle patterns besides plain variables
132 toJS (Def (PVar x) e)
133 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
134 | otherwise = assign x `liftM` toJS' e
136 toJS (Def pattern e) =
137 do n <- guid
138 let x = "_" ++ show n
139 var = Loc.none . Var
140 toDef y = Def (PVar y) (Loc.none $ Case (var x) [(pattern, var y)])
141 stmt <- assign x `liftM` toJS' e
142 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
143 return (stmt ++ vars)
145 toJS (TypeAnnotation _ _) = return ""
148instance ToJS a => ToJS [a] where
149 toJS xs = concat `liftM` mapM toJS xs
151toJS' :: LExpr t v -> Unique String
152toJS' (L txt span expr) =
153 case expr of
154 MultiIf ps -> multiIfToJS span ps
155 Case e cases -> caseToJS span e cases
156 _ -> toJS expr
158remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
159addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
160setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
161 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
162access x e = e ++ "." ++ x
163makeRecord kvs = record `liftM` collect kvs
164 where
165 combine r (k,v) = Map.insertWith (++) k v r
166 collect = liftM (foldl' combine Map.empty) . mapM prep
167 prep (k, e) =
168 do v <- toJS' e
169 return (k,[v])
170 fields fs =
171 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
172 hidden = fields . map (second jsList) .
173 filter (not . null . snd) . Map.toList . Map.map tail
174 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
177instance ToJS Literal where
178 toJS lit =
179 case lit of
180 Chr c -> return $ quoted [c]
181 Str s -> return $ "_str" ++ parens (quoted s)
182 IntNum n -> return $ show n
183 FloatNum n -> return $ show n
184 Boolean b -> return $ if b then "true" else "false"
187instance ToJS (Expr t v) where
188 toJS expr =
189 case expr of
190 Var x -> return x
191 Literal lit -> toJS lit
192 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
193 Access e x -> access x `liftM` toJS' e
194 Remove e x -> remove x `liftM` toJS' e
195 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
196 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
197 setField fs' `liftM` toJS' e
198 Record fs -> makeRecord fs
199 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
201 Lambda p e -> liftM (jsFunc (intercalate ", " args) . ret) (toJS' body)
202 where
203 (args, body) = foldr depattern ([], innerBody) (zip patterns [1..])
205 depattern (pattern,n) (args, body) =
206 case pattern of
207 PVar x -> (x:args, body)
208 _ -> let arg = "arg" ++ show n
209 in (arg:args, Loc.none (Case (Loc.none (Var arg)) [(pattern, body)]))
211 (patterns, innerBody) = collect [p] e
213 collect patterns lexpr@(L a b expr) =
214 case expr of
215 Lambda p e -> collect (p:patterns) e
216 _ -> (patterns, lexpr)
218 App e1 e2 -> jsApp e1 e2
219 Let defs e -> jsLet $ SD.flattenLets defs e
221 ExplicitList es ->
222 do es' <- mapM toJS' es
223 return $ "_J.toList" ++ parens (jsList es')
225 Data name es ->
226 do fs <- mapM toJS' es
227 return $ case name of
228 "[]" -> jsNil
229 "::" -> jsCons (head fs) ((head . tail) fs)
230 _ -> jsObj $ ("ctor:" ++ show name) : fields
231 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
233 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
234 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
235 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
237jsApp e1 e2 =
238 do f <- toJS' func
239 as <- mapM toJS' args
240 return $ case as of
241 [a] -> f ++ parens a
242 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
243 where
244 (func, args) = go [e2] e1
245 go args e =
246 case e of
247 (L _ _ (App e1 e2)) -> go (e2 : args) e1
248 _ -> (e, args)
250formatMarkdown = concatMap f
251 where f '\'' = "\\'"
252 f '\n' = "\\n"
253 f '"' = "\""
254 f c = [c]
256multiIfToJS span ps =
257 case last ps of
258 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
259 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
260 where
261 format base ps =
262 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
263 f (b,e) = do b' <- toJS' b
264 e' <- toJS' e
265 return (b' ++ " ? " ++ e')
267jsLet (defs,e') = do ds <- mapM toJS defs
268 e <- toJS' e'
269 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
271caseToJS span e ps = do
272 match <- caseToMatch ps
273 e' <- toJS' e
274 let (match',stmt) = case (match,e) of
275 (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
276 (Match name _ _, _) -> (match, assign name e')
277 _ -> (match, "")
278 matches <- matchToJS span match'
279 return $ "function(){ " ++ stmt ++ matches ++ " }()"
281matchToJS span match =
282 case match of
283 Match name clauses def ->
284 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
285 finally <- matchToJS span def
286 let isLiteral p = case p of
287 Clause (Right _) _ _ -> True
288 _ -> False
289 access = if any isLiteral clauses then "" else ".ctor"
290 return $ concat [ "\nswitch (", name, access, ") {"
291 , indent cases, "\n}", finally ]
292 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
293 Break -> return "break;"
294 Other e -> ret `liftM` toJS' e
295 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
296 where
297 dropEnd acc [] = acc
298 dropEnd acc (m:ms) =
299 case m of
300 Other _ -> acc ++ [m]
301 _ -> dropEnd (acc ++ [m]) ms
303clauseToJS span var (Clause value vars e) = do
304 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
305 s <- matchToJS span $ matchSubst (zip vars vars') e
306 return $ concat [ "\ncase ", case value of
307 Left name -> quoted name
308 Right (Boolean True) -> "true"
309 Right (Boolean False) -> "false"
310 Right lit -> show lit
311 , ":", indent s ]
313jsNil = "_L.Nil"
314jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
315jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
316jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
318binop (o:p) e1 e2
319 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
320 | otherwise =
321 let ops = ["+","-","*","/","&&","||"] in
322 case o:p of
323 "::" -> jsCons e1 e2
324 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
325 "<|" -> e1 ++ parens e2
326 "|>" -> e2 ++ parens e1
327 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
328 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
329 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
330 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
331 "<" -> jsCompare e1 e2 "==='LT'"
332 ">" -> jsCompare e1 e2 "==='GT'"
333 "<=" -> jsCompare e1 e2 "!=='GT'"
334 ">=" -> jsCompare e1 e2 "!=='LT'"
335 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
336 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
337 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
338 | otherwise -> concat [ "_op['", o:p, "']"
339 , parens e1, parens e2 ]