git.iko.soy/elk
on ed6b255 help sign in
elk/compiler/Generate/JavaScript.hs
362 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 . ret) (toJS' body)
195 where
196 fastFunc body
197 | length args < 2 || length args > 9 = foldr jsFunc body args
198 | otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)
199 (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
201 depattern (pattern,n) (args, body) =
202 case pattern of
203 PVar x -> (deprime x : args, body)
204 _ -> let arg = "arg" ++ show n
205 in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
207 (patterns, innerBody) = collect [p] e
209 collect patterns lexpr@(L _ expr) =
210 case expr of
211 Lambda p e -> collect (p:patterns) e
212 _ -> (patterns, lexpr)
214 App e1 e2 -> jsApp e1 e2
215 Let defs e -> jsLet $ SD.flattenLets defs e
217 ExplicitList es ->
218 do es' <- mapM toJS' es
219 return $ "_J.toList" ++ parens (jsList es')
221 Data name es ->
222 do fs <- mapM toJS' es
223 return $ case name of
224 "[]" -> jsNil
225 "::" -> jsCons (head fs) ((head . tail) fs)
226 _ -> jsObj $ ("ctor:" ++ show name) : fields
227 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
229 Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
230 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
231 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
233jsApp e1 e2 =
234 do f <- toJS' func
235 as <- mapM toJS' args
236 return $ case as of
237 [a] -> f ++ parens a
238 _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
239 where
240 (func, args) = go [e2] e1
241 go args e =
242 case e of
243 (L _ (App e1 e2)) -> go (e2 : args) e1
244 _ -> (e, args)
246formatMarkdown = concatMap f
247 where f '\'' = "\\'"
248 f '\n' = "\\n"
249 f '"' = "\""
250 f c = [c]
252multiIfToJS span ps =
253 case last ps of
254 (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
255 _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps
256 where
257 format base ps =
258 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
259 f (b,e) = do b' <- toJS' b
260 e' <- toJS' e
261 return (b' ++ " ? " ++ e')
263jsLet (defs,e') = do ds <- mapM toJS defs
264 e <- toJS' e'
265 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
267caseToJS span e ps = do
268 (tempVar,match) <- caseToMatch ps
269 e' <- toJS' e
270 let (match',stmt) = case e of
271 L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")
272 _ -> (match, assign tempVar e')
273 matches <- matchToJS span match'
274 return $ jsFunc "" (stmt ++ matches) ++ "()"
276matchToJS span match =
277 case match of
278 Match name clauses def ->
279 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
280 finally <- matchToJS span def
281 let isLiteral p = case p of
282 Clause (Right _) _ _ -> True
283 _ -> False
284 access = if any isLiteral clauses then "" else ".ctor"
285 return $ concat [ "\nswitch (", name, access, ") {"
286 , indent cases, "\n}", finally ]
287 Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
288 Break -> return "break;"
289 Other e -> ret `liftM` toJS' e
290 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
291 where
292 dropEnd acc [] = acc
293 dropEnd acc (m:ms) =
294 case m of
295 Other _ -> acc ++ [m]
296 _ -> dropEnd (acc ++ [m]) ms
298clauseToJS span var (Clause value vars e) = do
299 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
300 s <- matchToJS span $ matchSubst (zip vars vars') e
301 return $ concat [ "\ncase ", case value of
302 Right (Boolean True) -> "true"
303 Right (Boolean False) -> "false"
304 Right lit -> show lit
305 Left name -> quoted $ case List.elemIndices '.' name of
306 [] -> name
307 is -> drop (last is + 1) name
308 , ":", indent s ]
310jsNil = "_L.Nil"
311jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
312jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
313jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
316binop op e1 e2
317 | op == "Basics.." =
318 do ss <- mapM toJS' (e1 : collect [] e2)
319 return . jsFunc "$" . ret $ apply "$" ss
320 | op == "Basics.<|" =
321 do arg <- toJS' e2
322 funcs <- mapM toJS' (collect [] e1)
323 return (apply arg funcs)
324 | otherwise =
325 binopNormal op `liftM` toJS' e1 `ap` toJS' e2
326 where
327 apply = foldr (\f arg-> f ++ parens arg)
329 collect es e =
330 case e of
331 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
332 _ -> es ++ [e]
334binopNormal op s1 s2 =
335 case Map.lookup op opDict of
336 Just e -> e
337 Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])
338 where
339 func | isOp op' = "_op['" ++ op' ++ "']"
340 | otherwise = op'
341 (prefix, op') = case List.elemIndices '.' op of
342 [] -> ("", op)
343 xs -> splitAt (last xs + 1) op
345 opDict = Map.fromList $ basics ++
346 [ ("::", jsCons s1 s2)
347 , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
349 ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
350 where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")
352 basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
353 (ops ++ [ ("<|", s1 ++ parens s2)
354 , ("|>", s2 ++ parens s1)
355 , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
356 , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
357 , ("<" , jsCompare s1 s2 "<0")
358 , (">" , jsCompare s1 s2 ">0")
359 , ("<=", jsCompare s1 s2 "<1")
360 , (">=", jsCompare s1 s2 ">-1")
361 , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
362 ])