git.iko.soy/elk
on 520c81f help sign in
elk/compiler/Generate/JavaScript.hs
350 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
16import qualified Transform.SortDefinitions as SD
18deprime :: String -> String
19deprime = map (\c -> if c == '\'' then '$' else c)
21showErr :: String -> String
22showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
23 where msg = show . concatMap (++"<br>") . lines $ err
24 body = "var T = Elm.Text(elm);\n\
25 \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
27indent = concatMap f
28 where f '\n' = "\n "
29 f c = [c]
31internalImports =
32 [ ("N" , "Elm.Native"),
33 ("_N", "N.Utils(elm)"),
34 ("_L", "N.List(elm)"),
35 ("_E", "N.Error(elm)"),
36 ("_J", "N.JavaScript(elm)"),
37 ("_str", "_J.toString")
38 ]
40parens s = "(" ++ s ++ ")"
41brackets s = "{" ++ s ++ "}"
42commaSep = List.intercalate ", "
43dotSep = List.intercalate "."
44jsObj = brackets . commaSep
45jsList ss = "["++ List.intercalate "," ss ++"]"
46jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
47assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
48ret e = "\nreturn "++ e ++";"
49quoted s = "'" ++ concatMap f s ++ "'"
50 where f '\n' = "\\n"
51 f '\'' = "\\'"
52 f '\t' = "\\t"
53 f '\"' = "\\\""
54 f '\\' = "\\\\"
55 f c = [c]
57globalAssign n e = "\n" ++ assign' n e ++ ";"
58assign' n e = n ++ " = " ++ e
60jsModule :: MetadataModule t v -> String
61jsModule modul =
62 run $ do
63 body <- toJS . fst . SD.flattenLets [] $ program modul
64 foreignImport <- mapM importEvent (foreignImports modul)
65 return $ concat [ setup ("Elm": names modul)
66 , globalAssign ("Elm." ++ modName)
67 (jsFunc "elm" $ makeProgram body foreignImport) ]
68 where
69 modName = dotSep (names modul)
70 makeProgram body foreignImport =
71 concat [ "\nvar " ++ usefulFuncs ++ ";"
72 , concatMap jsImport (imports modul)
73 , concat foreignImport
74 , assign "_op" "{}"
75 , body
76 , concatMap exportEvent $ foreignExports modul
77 , jsExports
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 jsExports = setup ("elm" : names modul) ++
84 ret (assign' ("elm." ++ modName) (brackets exs))
85 where
86 exs = indent . commaSep . concatMap (pair . deprime) $ "_op" : exports modul
87 pair x | isOp x = []
88 | otherwise = ["\n" ++ x ++ " : " ++ x]
91 importEvent (js,base,elm,_) =
92 do v <- toJS' base
93 return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
94 , "\ndocument.addEventListener('", js
95 , "_' + elm.id, function(e) { elm.notify(", elm
96 , ".id, e.value); });" ]
98 exportEvent (js,elm,_) =
99 concat [ "\nA2( Signal.lift, function(v) { "
100 , "var e = document.createEvent('Event');"
101 , "e.initEvent('", js, "_' + elm.id, true, true);"
102 , "e.value = v;"
103 , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
105jsImport (modul, method) =
106 concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
107 where
108 starters = "\nvar " : repeat "\n"
109 values = map (\name -> name ++ " || {}") (init subnames) ++
110 ["Elm." ++ modul ++ parens "elm"]
111 subnames = map dotSep . tail . List.inits $ split modul
113 split names = case go [] names of
114 (name, []) -> [name]
115 (name, ns) -> name : split ns
116 go name str = case str of
117 '.':rest -> (reverse name, rest)
118 c:rest -> go (c:name) rest
119 [] -> (reverse name, [])
122class ToJS a where
123 toJS :: a -> Unique String
126instance ToJS (Def t v) where
128 -- TODO: Make this handle patterns besides plain variables
129 toJS (Def (PVar x) e)
130 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
131 | otherwise = assign (deprime x) `liftM` toJS' e
133 toJS (Def pattern e@(L s _)) =
134 do n <- guid
135 let x = "_" ++ show n
136 var = L s . Var
137 toDef y' = let y = deprime y' in
138 Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
139 stmt <- assign x `liftM` toJS' e
140 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
141 return (stmt ++ vars)
143 toJS (TypeAnnotation _ _) = return ""
146instance ToJS a => ToJS [a] where
147 toJS xs = concat `liftM` mapM toJS xs
149toJS' :: LExpr t v -> Unique String
150toJS' (L span expr) =
151 case expr of
152 MultiIf ps -> multiIfToJS span ps
153 Case e cases -> caseToJS span e cases
154 _ -> toJS expr
156remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
157addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
158setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
159 where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
160access x e = e ++ "." ++ deprime x
161makeRecord kvs = record `liftM` collect kvs
162 where
163 combine r (k,v) = Map.insertWith (++) k v r
164 collect = liftM (List.foldl' combine Map.empty) . mapM prep
165 prep (k, e) =
166 do v <- toJS' e
167 return (deprime k, [v])
168 fields fs =
169 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
170 hidden = fields . map (second jsList) .
171 filter (not . null . snd) . Map.toList . Map.map tail
172 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
175instance ToJS Literal where
176 toJS lit =
177 case lit of
178 Chr c -> return $ quoted [c]
179 Str s -> return $ "_str" ++ parens (quoted s)
180 IntNum n -> return $ show n
181 FloatNum n -> return $ show n
182 Boolean b -> return $ if b then "true" else "false"
185instance ToJS (Expr t v) where
186 toJS expr =
187 case expr of
188 Var x -> return (deprime x)
189 Literal lit -> toJS lit
190 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
191 Access e x -> access x `liftM` toJS' e
192 Remove e x -> remove x `liftM` toJS' e
193 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
194 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
195 setField fs' `liftM` toJS' e
196 Record fs -> makeRecord fs
197 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
199 Lambda p e@(L s _) -> liftM (fastFunc . ret) (toJS' body)
200 where
201 fastFunc body
202 | length args < 2 || length args > 9 = foldr jsFunc body args
203 | otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)
204 (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
206 depattern (pattern,n) (args, body) =
207 case pattern of
208 PVar x -> (deprime x : args, body)
209 _ -> let arg = "arg" ++ show n
210 in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
212 (patterns, innerBody) = collect [p] e
214 collect patterns lexpr@(L _ expr) =
215 case expr of
216 Lambda p e -> collect (p:patterns) e
217 _ -> (patterns, lexpr)
219 App e1 e2 -> jsApp e1 e2
220 Let defs e -> jsLet $ SD.flattenLets defs e
222 ExplicitList es ->
223 do es' <- mapM toJS' es
224 return $ "_J.toList" ++ parens (jsList es')
226 Data name es ->
227 do fs <- mapM toJS' es
228 return $ case name of
229 "[]" -> jsNil
230 "::" -> jsCons (head fs) ((head . tail) fs)
231 _ -> jsObj $ ("ctor:" ++ show name) : fields
232 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
234 Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
235 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
236 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
238jsApp e1 e2 =
239 do f <- toJS' func
240 as <- mapM toJS' args
241 return $ case as of
242 [a] -> f ++ parens a
243 _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
244 where
245 (func, args) = go [e2] e1
246 go args e =
247 case e of
248 (L _ (App e1 e2)) -> go (e2 : args) e1
249 _ -> (e, args)
251formatMarkdown = concatMap f
252 where f '\'' = "\\'"
253 f '\n' = "\\n"
254 f '"' = "\""
255 f c = [c]
257multiIfToJS span ps =
258 case last ps of
259 (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
260 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
261 where
262 format base ps =
263 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
264 f (b,e) = do b' <- toJS' b
265 e' <- toJS' e
266 return (b' ++ " ? " ++ e')
268jsLet (defs,e') = do ds <- mapM toJS defs
269 e <- toJS' e'
270 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
272caseToJS span e ps = do
273 (tempVar,match) <- caseToMatch ps
274 e' <- toJS' e
275 let (match',stmt) = case e of
276 L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")
277 _ -> (match, assign tempVar e')
278 matches <- matchToJS span match'
279 return $ jsFunc "" (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 Right (Boolean True) -> "true"
308 Right (Boolean False) -> "false"
309 Right lit -> show lit
310 Left name -> quoted $ case List.elemIndices '.' name of
311 [] -> name
312 is -> drop (last is + 1) name
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 ++ ")" ++ op)
321binop op e1 e2 =
322 case Map.lookup op opDict of
323 Just e -> e
324 Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, e1, e2 ])
325 where
326 func | isOp op' = "_op['" ++ op' ++ "']"
327 | otherwise = op'
328 (prefix, op') = case List.elemIndices '.' op of
329 [] -> ("", op)
330 xs -> splitAt (last xs + 1) op
331 where
332 opDict = Map.fromList $ basics ++
333 [ ("::", jsCons e1 e2)
334 , ("List.++", "_L.append" ++ parens (e1 ++ "," ++ e2)) ]
336 ops = pow : map (\op -> (op, parens (e1 ++ op ++ e2))) ["+","-","*","/","&&","||"]
337 where pow = ("^" , "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")")
339 basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
340 (ops ++ [ ("<|", e1 ++ parens e2)
341 , ("|>", e2 ++ parens e1)
342 , ("." , jsFunc "$" . ret $ e1 ++ parens (e2 ++ parens "$"))
343 , ("==", "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")")
344 , ("/=", "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")")
345 , ("<" , jsCompare e1 e2 "<0")
346 , (">" , jsCompare e1 e2 ">0")
347 , ("<=", jsCompare e1 e2 "<1")
348 , (">=", jsCompare e1 e2 ">-1")
349 , ("div", parens (e1 ++ "/" ++ e2 ++ "|0"))
350 ])