git.iko.soy/elk
on 555cdc6 help sign in
elk/compiler/Generate/JavaScript.hs
368 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
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 name =
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 ("$moduleName", quoted name)
39 ]
41parens s = "(" ++ s ++ ")"
42brackets s = "{" ++ s ++ "}"
43commaSep = List.intercalate ", "
44dotSep = List.intercalate "."
45jsObj = brackets . commaSep
46jsList ss = "["++ List.intercalate "," ss ++"]"
47jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
48assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
49ret e = "\nreturn "++ e ++";"
50quoted s = "'" ++ concatMap f s ++ "'"
51 where f '\n' = "\\n"
52 f '\'' = "\\'"
53 f '\t' = "\\t"
54 f '\"' = "\\\""
55 f '\\' = "\\\\"
56 f c = [c]
58globalAssign n e = "\n" ++ assign' n e ++ ";"
59assign' n e = n ++ " = " ++ e
61jsModule :: MetadataModule t v -> String
62jsModule modul =
63 run $ do
64 body <- toJS . fst . SD.flattenLets [] $ program modul
65 foreignImport <- mapM importEvent (foreignImports modul)
66 return $ concat [ setup ("Elm": names modul)
67 , globalAssign ("Elm." ++ modName)
68 (jsFunc "elm" $ makeProgram body foreignImport) ]
69 where
70 modName = dotSep (names modul)
71 makeProgram body foreignImport =
72 concat [ "\nvar " ++ usefulFuncs ++ ";"
73 , concatMap jsImport (imports modul)
74 , concat foreignImport
75 , assign "_op" "{}"
76 , body
77 , concatMap exportEvent $ foreignExports modul
78 , jsExports
79 ]
80 setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
81 map dotSep . drop 2 . List.inits $ init names
82 usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
84 jsExports = setup ("elm" : names modul) ++
85 ret (assign' ("elm." ++ modName) (brackets exs))
86 where
87 exs = indent . commaSep . concatMap (pair . deprime) $ "_op" : exports modul
88 pair x | isOp x = []
89 | otherwise = ["\n" ++ x ++ " : " ++ x]
92 importEvent (js,base,elm,_) =
93 do v <- toJS' base
94 return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
95 , "\ndocument.addEventListener('", js
96 , "_' + elm.id, function(e) { elm.notify(", elm
97 , ".id, e.value); });" ]
99 exportEvent (js,elm,_) =
100 concat [ "\nA2( Signal.lift, function(v) { "
101 , "var e = document.createEvent('Event');"
102 , "e.initEvent('", js, "_' + elm.id, true, true);"
103 , "e.value = v;"
104 , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
106jsImport (modul, method) =
107 concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
108 where
109 starters = "\nvar " : repeat "\n"
110 values = map (\name -> name ++ " || {}") (init subnames) ++
111 ["Elm." ++ modul ++ parens "elm"]
112 subnames = map dotSep . tail . List.inits $ split modul
114 split names = case go [] names of
115 (name, []) -> [name]
116 (name, ns) -> name : split ns
117 go name str = case str of
118 '.':rest -> (reverse name, rest)
119 c:rest -> go (c:name) rest
120 [] -> (reverse name, [])
123class ToJS a where
124 toJS :: a -> Unique String
127instance ToJS (Def t v) where
129 -- TODO: Make this handle patterns besides plain variables
130 toJS (Def (PVar x) e)
131 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
132 | otherwise = assign (deprime x) `liftM` toJS' e
134 toJS (Def pattern e@(L s _)) =
135 do n <- guid
136 let x = "_" ++ show n
137 var = L s . Var
138 toDef y' = let y = deprime y' in
139 Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
140 stmt <- assign x `liftM` toJS' e
141 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
142 return (stmt ++ vars)
144 toJS (TypeAnnotation _ _) = return ""
147instance ToJS a => ToJS [a] where
148 toJS xs = concat `liftM` mapM toJS xs
150toJS' :: LExpr t v -> Unique String
151toJS' (L span expr) =
152 case expr of
153 MultiIf ps -> multiIfToJS span ps
154 Case e cases -> caseToJS span e cases
155 _ -> toJS expr
157remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
158addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
159setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
160 where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
161access x e = e ++ "." ++ deprime x
162makeRecord kvs = record `liftM` collect kvs
163 where
164 combine r (k,v) = Map.insertWith (++) k v r
165 collect = liftM (List.foldl' combine Map.empty) . mapM prep
166 prep (k, e) =
167 do v <- toJS' e
168 return (deprime k, [v])
169 fields fs =
170 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
171 hidden = fields . map (second jsList) .
172 filter (not . null . snd) . Map.toList . Map.map tail
173 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
176instance ToJS Literal where
177 toJS lit =
178 case lit of
179 Chr c -> return $ quoted [c]
180 Str s -> return $ "_str" ++ parens (quoted s)
181 IntNum n -> return $ show n
182 FloatNum n -> return $ show n
183 Boolean b -> return $ if b then "true" else "false"
186instance ToJS (Expr t v) where
187 toJS expr =
188 case expr of
189 Var x -> return (deprime x)
190 Literal lit -> toJS lit
191 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
192 Access e x -> access x `liftM` toJS' e
193 Remove e x -> remove x `liftM` toJS' e
194 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
195 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
196 setField fs' `liftM` toJS' e
197 Record fs -> makeRecord fs
198 Binop op e1 e2 -> binop op e1 e2
200 Lambda p e@(L s _) -> liftM (fastFunc . ret) (toJS' body)
201 where
202 fastFunc body
203 | length args < 2 || length args > 9 = foldr jsFunc body args
204 | otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)
205 (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
207 depattern (pattern,n) (args, body) =
208 case pattern of
209 PVar x -> (deprime x : args, body)
210 _ -> let arg = "arg" ++ show n
211 in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
213 (patterns, innerBody) = collect [p] e
215 collect patterns lexpr@(L _ 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.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 ("$moduleName," ++ 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 (tempVar,match) <- caseToMatch ps
275 e' <- toJS' e
276 let (match',stmt) = case e of
277 L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")
278 _ -> (match, assign tempVar e')
279 matches <- matchToJS span match'
280 return $ jsFunc "" (stmt ++ matches) ++ "()"
282matchToJS span match =
283 case match of
284 Match name clauses def ->
285 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
286 finally <- matchToJS span def
287 let isLiteral p = case p of
288 Clause (Right _) _ _ -> True
289 _ -> False
290 access = if any isLiteral clauses then "" else ".ctor"
291 return $ concat [ "\nswitch (", name, access, ") {"
292 , indent cases, "\n}", finally ]
293 Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
294 Break -> return "break;"
295 Other e -> ret `liftM` toJS' e
296 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
297 where
298 dropEnd acc [] = acc
299 dropEnd acc (m:ms) =
300 case m of
301 Other _ -> acc ++ [m]
302 _ -> dropEnd (acc ++ [m]) ms
304clauseToJS span var (Clause value vars e) = do
305 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
306 s <- matchToJS span $ matchSubst (zip vars vars') e
307 return $ concat [ "\ncase ", case value of
308 Right (Boolean True) -> "true"
309 Right (Boolean False) -> "false"
310 Right lit -> show lit
311 Left name -> quoted $ case List.elemIndices '.' name of
312 [] -> name
313 is -> drop (last is + 1) name
314 , ":", indent s ]
316jsNil = "_L.Nil"
317jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
318jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
319jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
322binop op e1 e2
323 | op == "Basics.." =
324 do ss <- mapM toJS' (e1 : collect [] e2)
325 return . jsFunc "$" . ret $ apply "$" ss
326 | op == "Basics.<|" =
327 do arg <- toJS' e2
328 funcs <- mapM toJS' (collect [] e1)
329 return (apply arg funcs)
330 | otherwise =
331 binopNormal op `liftM` toJS' e1 `ap` toJS' e2
332 where
333 apply = foldr (\f arg-> f ++ parens arg)
335 collect es e =
336 case e of
337 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
338 _ -> es ++ [e]
340binopNormal op s1 s2 =
341 case Map.lookup op opDict of
342 Just e -> e
343 Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])
344 where
345 func | isOp op' = "_op['" ++ op' ++ "']"
346 | otherwise = op'
347 (prefix, op') = case List.elemIndices '.' op of
348 [] -> ("", op)
349 xs -> splitAt (last xs + 1) op
351 opDict = Map.fromList $ basics ++
352 [ ("::", jsCons s1 s2)
353 , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
355 ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
356 where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")
358 basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
359 (ops ++ [ ("<|", s1 ++ parens s2)
360 , ("|>", s2 ++ parens s1)
361 , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
362 , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
363 , ("<" , jsCompare s1 s2 "<0")
364 , (">" , jsCompare s1 s2 ">0")
365 , ("<=", jsCompare s1 s2 "<1")
366 , (">=", jsCompare s1 s2 ">-1")
367 , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
368 ])