git.iko.soy/elk
on b23ff22 help sign in
elk/compiler/Generate/JavaScript.hs
365 lines 13 kB history raw
1module Generate.JavaScript (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
15import SourceSyntax.Location
16import qualified Transform.SortDefinitions as SD
18deprime :: String -> String
19deprime = map (\c -> if c == '\'' then '$' else c)
21indent = concatMap f
22 where f '\n' = "\n "
23 f c = [c]
25internalImports name =
26 [ ("N" , "Elm.Native"),
27 ("_N", "N.Utils(elm)"),
28 ("_L", "N.List(elm)"),
29 ("_E", "N.Error(elm)"),
30 ("_J", "N.JavaScript(elm)"),
31 ("_str", "_J.toString"),
32 ("$moduleName", quoted name)
33 ]
35parens s = "(" ++ s ++ ")"
36brackets s = "{" ++ s ++ "}"
37commaSep = List.intercalate ", "
38dotSep = List.intercalate "."
39jsObj = brackets . commaSep
40jsList ss = "["++ List.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 = dotSep (names modul)
65 makeProgram body foreignImport =
66 concat [ "\nvar " ++ usefulFuncs ++ ";"
67 , concatMap jsImport (imports modul)
68 , concat foreignImport
69 , assign "_op" "{}"
70 , body
71 , concatMap exportEvent $ foreignExports modul
72 , jsExports
73 ]
74 setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
75 map dotSep . drop 2 . List.inits $ init names
76 usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
78 jsExports = setup ("elm" : names modul) ++
79 ret (assign' ("elm." ++ modName) (brackets exs))
80 where
81 exs = indent . commaSep . concatMap (pair . deprime) $ "_op" : exports modul
82 pair x | isOp x = []
83 | otherwise = ["\n" ++ x ++ " : " ++ x]
86 importEvent (js,base,elm,_) =
87 do v <- toJS' base
88 return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
89 , "\ndocument.addEventListener('", js
90 , "_' + elm.id, function(e) { elm.notify(", elm
91 , ".id, e.value); });" ]
93 exportEvent (js,elm,_) =
94 concat [ "\nA2( Signal.lift, 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, method) =
101 concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
102 where
103 starters = "\nvar " : repeat "\n"
104 values = map (\name -> name ++ " || {}") (init subnames) ++
105 ["Elm." ++ modul ++ parens "elm"]
106 subnames = map dotSep . tail . List.inits $ split modul
108 split names = case go [] names of
109 (name, []) -> [name]
110 (name, ns) -> name : split ns
111 go name str = case str of
112 '.':rest -> (reverse name, rest)
113 c:rest -> go (c:name) rest
114 [] -> (reverse name, [])
117class ToJS a where
118 toJS :: a -> Unique String
121instance ToJS (Def t v) where
123 -- TODO: Make this handle patterns besides plain variables
124 toJS (Def (PVar x) e)
125 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
126 | otherwise = assign (deprime x) `liftM` toJS' e
128 toJS (Def pattern e@(L s _)) =
129 do n <- guid
130 let x = "_" ++ show n
131 var = L s . Var
132 toDef y' = let y = deprime y' in
133 Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
134 stmt <- assign x `liftM` toJS' e
135 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
136 return (stmt ++ vars)
138 toJS (TypeAnnotation _ _) = return ""
141instance ToJS a => ToJS [a] where
142 toJS xs = concat `liftM` mapM toJS xs
144toJS' :: LExpr t v -> Unique String
145toJS' (L span expr) =
146 case expr of
147 MultiIf ps -> multiIfToJS span ps
148 Case e cases -> caseToJS span e cases
149 _ -> toJS expr
151remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
152addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
153setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
154 where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
155access x e = e ++ "." ++ deprime x
156makeRecord kvs = record `liftM` collect kvs
157 where
158 combine r (k,v) = Map.insertWith (++) k v r
159 collect = liftM (List.foldl' combine Map.empty) . mapM prep
160 prep (k, e) =
161 do v <- toJS' e
162 return (deprime k, [v])
163 fields fs =
164 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
165 hidden = fields . map (second jsList) .
166 filter (not . null . snd) . Map.toList . Map.map tail
167 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
170instance ToJS Literal where
171 toJS lit =
172 case lit of
173 Chr c -> return $ quoted [c]
174 Str s -> return $ "_str" ++ parens (quoted s)
175 IntNum n -> return $ show n
176 FloatNum n -> return $ show n
177 Boolean b -> return $ if b then "true" else "false"
180instance ToJS (Expr t v) where
181 toJS expr =
182 case expr of
183 Var x -> return (deprime x)
184 Literal lit -> toJS lit
185 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
186 Access e x -> access x `liftM` toJS' e
187 Remove e x -> remove x `liftM` toJS' e
188 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
189 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
190 setField fs' `liftM` toJS' e
191 Record fs -> makeRecord fs
192 Binop op e1 e2 -> binop op e1 e2
194 Lambda p e@(L s _) -> liftM fastFunc (toJS' body)
195 where
196 fastFunc body
197 | length args < 2 || length args > 9 =
198 foldr (\arg bod -> jsFunc arg (ret bod)) body args
199 | otherwise =
200 "F" ++ show (length args) ++ parens (jsFunc (commaSep args) (ret body))
202 (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
204 depattern (pattern,n) (args, body) =
205 case pattern of
206 PVar x -> (deprime x : args, body)
207 _ -> let arg = "arg" ++ show n
208 in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
210 (patterns, innerBody) = collect [p] e
212 collect patterns lexpr@(L _ expr) =
213 case expr of
214 Lambda p e -> collect (p:patterns) e
215 _ -> (patterns, lexpr)
217 App e1 e2 -> jsApp e1 e2
218 Let defs e -> jsLet $ SD.flattenLets defs e
220 ExplicitList es ->
221 do es' <- mapM toJS' es
222 return $ "_J.toList" ++ parens (jsList es')
224 Data name es ->
225 do fs <- mapM toJS' es
226 return $ case name of
227 "[]" -> jsNil
228 "::" -> jsCons (head fs) ((head . tail) fs)
229 _ -> jsObj $ ("ctor:" ++ show name) : fields
230 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
232 Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
233 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
234 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
236jsApp e1 e2 =
237 do f <- toJS' func
238 as <- mapM toJS' args
239 return $ case as of
240 [a] -> f ++ parens a
241 _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
242 where
243 (func, args) = go [e2] e1
244 go args e =
245 case e of
246 (L _ (App e1 e2)) -> go (e2 : args) e1
247 _ -> (e, args)
249formatMarkdown = concatMap f
250 where f '\'' = "\\'"
251 f '\n' = "\\n"
252 f '"' = "\""
253 f c = [c]
255multiIfToJS span ps =
256 case last ps of
257 (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
258 _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps
259 where
260 format base ps =
261 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
262 f (b,e) = do b' <- toJS' b
263 e' <- toJS' e
264 return (b' ++ " ? " ++ e')
266jsLet (defs,e') = do ds <- mapM toJS defs
267 e <- toJS' e'
268 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
270caseToJS span e ps = do
271 (tempVar,match) <- caseToMatch ps
272 e' <- toJS' e
273 let (match',stmt) = case e of
274 L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")
275 _ -> (match, assign tempVar e')
276 matches <- matchToJS span match'
277 return $ jsFunc "" (stmt ++ matches) ++ "()"
279matchToJS span match =
280 case match of
281 Match name clauses def ->
282 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
283 finally <- matchToJS span def
284 let isLiteral p = case p of
285 Clause (Right _) _ _ -> True
286 _ -> False
287 access = if any isLiteral clauses then "" else ".ctor"
288 return $ concat [ "\nswitch (", name, access, ") {"
289 , indent cases, "\n}", finally ]
290 Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
291 Break -> return "break;"
292 Other e -> ret `liftM` toJS' e
293 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
294 where
295 dropEnd acc [] = acc
296 dropEnd acc (m:ms) =
297 case m of
298 Other _ -> acc ++ [m]
299 _ -> dropEnd (acc ++ [m]) ms
301clauseToJS span var (Clause value vars e) = do
302 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
303 s <- matchToJS span $ matchSubst (zip vars vars') e
304 return $ concat [ "\ncase ", case value of
305 Right (Boolean True) -> "true"
306 Right (Boolean False) -> "false"
307 Right lit -> show lit
308 Left name -> quoted $ case List.elemIndices '.' name of
309 [] -> name
310 is -> drop (last is + 1) name
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 ++ ")" ++ op)
319binop op e1 e2
320 | op == "Basics.." =
321 do ss <- mapM toJS' (e1 : collect [] e2)
322 return . jsFunc "$" . ret $ apply "$" ss
323 | op == "Basics.<|" =
324 do arg <- toJS' e2
325 funcs <- mapM toJS' (collect [] e1)
326 return (apply arg funcs)
327 | otherwise =
328 binopNormal op `liftM` toJS' e1 `ap` toJS' e2
329 where
330 apply = foldr (\f arg-> f ++ parens arg)
332 collect es e =
333 case e of
334 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
335 _ -> es ++ [e]
337binopNormal op s1 s2 =
338 case Map.lookup op opDict of
339 Just e -> e
340 Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])
341 where
342 func | isOp op' = "_op['" ++ op' ++ "']"
343 | otherwise = op'
344 (prefix, op') = case List.elemIndices '.' op of
345 [] -> ("", op)
346 xs -> splitAt (last xs + 1) op
348 opDict = Map.fromList $ basics ++
349 [ ("::", jsCons s1 s2)
350 , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
352 ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
353 where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")
355 basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
356 (ops ++ [ ("<|", s1 ++ parens s2)
357 , ("|>", s2 ++ parens s1)
358 , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
359 , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
360 , ("<" , jsCompare s1 s2 "<0")
361 , (">" , jsCompare s1 s2 ">0")
362 , ("<=", jsCompare s1 s2 "<1")
363 , (">=", jsCompare s1 s2 ">-1")
364 , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
365 ])