git.iko.soy/elk
on ca75e60 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
18indent = concatMap f
19 where f '\n' = "\n "
20 f c = [c]
22internalImports name =
23 [ ("N" , "Elm.Native"),
24 ("_N", "N.Utils(elm)"),
25 ("_L", "N.List(elm)"),
26 ("_E", "N.Error(elm)"),
27 ("_J", "N.JavaScript(elm)"),
28 ("_str", "_J.toString"),
29 ("$moduleName", quoted name)
30 ]
32parens s = "(" ++ s ++ ")"
33brackets s = "{" ++ s ++ "}"
34commaSep = List.intercalate ", "
35dotSep = List.intercalate "."
36jsObj = brackets . commaSep
37jsList ss = "["++ List.intercalate "," ss ++"]"
38jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
39assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
40ret e = "\nreturn "++ e ++";"
41quoted s = "'" ++ concatMap f s ++ "'"
42 where f '\n' = "\\n"
43 f '\'' = "\\'"
44 f '\t' = "\\t"
45 f '\"' = "\\\""
46 f '\\' = "\\\\"
47 f c = [c]
49globalAssign n e = "\n" ++ assign' n e ++ ";"
50assign' n e = n ++ " = " ++ e
52jsModule :: MetadataModule t v -> String
53jsModule modul =
54 run $ do
55 body <- toJS . fst . SD.flattenLets [] $ program modul
56 foreignImport <- mapM importEvent (foreignImports modul)
57 return $ concat [ setup ("Elm" : names modul)
58 , globalAssign ("Elm." ++ modName)
59 (jsFunc "elm" $ makeProgram body foreignImport) ]
60 where
61 modName = dotSep (names modul)
62 makeProgram body foreignImport =
63 concat [ setup ("elm" : names modul)
64 , "\nif (elm." ++ modName ++ ") return elm." ++ modName ++ ";"
65 , "\nvar " ++ usefulFuncs ++ ";"
66 , concatMap jsImport (imports modul)
67 , concat foreignImport
68 , assign "_op" "{}"
69 , body
70 , concatMap exportEvent $ foreignExports modul
71 , jsExports
72 ]
73 setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
74 map dotSep . drop 2 . List.inits $ init names
75 usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
77 jsExports = ret (assign' ("elm." ++ modName) (brackets exs))
78 where
79 exs = indent . commaSep . concatMap pair $ "_op" : exports modul
80 pair x | isOp x = []
81 | otherwise = ["\n" ++ x ++ " : " ++ x]
84 importEvent (js,base,elm,_) =
85 do v <- toJS' base
86 return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
87 , "\ndocument.addEventListener('", js
88 , "_' + elm.id, function(e) { elm.notify(", elm
89 , ".id, e.value); });" ]
91 exportEvent (js,elm,_) =
92 concat [ "\nA2( Signal.lift, function(v) { "
93 , "var e = document.createEvent('Event');"
94 , "e.initEvent('", js, "_' + elm.id, true, true);"
95 , "e.value = v;"
96 , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
98jsImport (modul, method) =
99 concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
100 where
101 starters = "\nvar " : repeat "\n"
102 values = map (\name -> name ++ " || {}") (init subnames) ++
103 ["Elm." ++ modul ++ parens "elm"]
104 subnames = map dotSep . tail . List.inits $ split modul
106 split names = case go [] names of
107 (name, []) -> [name]
108 (name, ns) -> name : split ns
109 go name str = case str of
110 '.':rest -> (reverse name, rest)
111 c:rest -> go (c:name) rest
112 [] -> (reverse name, [])
115class ToJS a where
116 toJS :: a -> Unique String
119instance ToJS (Def t v) where
121 -- TODO: Make this handle patterns besides plain variables
122 toJS (Def (PVar x) e)
123 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
124 | otherwise = assign x `liftM` toJS' e
126 toJS (Def pattern e@(L s _)) =
127 do n <- guid
128 let x = "_" ++ show n
129 var = L s . Var
130 toDef y = Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
131 stmt <- assign x `liftM` toJS' e
132 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
133 return (stmt ++ vars)
135 toJS (TypeAnnotation _ _) = return ""
138instance ToJS a => ToJS [a] where
139 toJS xs = concat `liftM` mapM toJS xs
141toJS' :: LExpr t v -> Unique String
142toJS' (L span expr) =
143 case expr of
144 MultiIf ps -> multiIfToJS span ps
145 Case e cases -> caseToJS span e cases
146 _ -> toJS expr
148remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
149addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
150setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
151 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
152access x e = e ++ "." ++ x
153makeRecord kvs = record `liftM` collect kvs
154 where
155 combine r (k,v) = Map.insertWith (++) k v r
156 collect = liftM (List.foldl' combine Map.empty) . mapM prep
157 prep (k, e) =
158 do v <- toJS' e
159 return (k, [v])
160 fields fs =
161 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
162 hidden = fields . map (second jsList) .
163 filter (not . null . snd) . Map.toList . Map.map tail
164 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
167instance ToJS Literal where
168 toJS lit =
169 case lit of
170 Chr c -> return $ quoted [c]
171 Str s -> return $ "_str" ++ parens (quoted s)
172 IntNum n -> return $ show n
173 FloatNum n -> return $ show n
174 Boolean b -> return $ if b then "true" else "false"
177instance ToJS (Expr t v) where
178 toJS expr =
179 case expr of
180 Var x -> return x
181 Literal lit -> toJS lit
182 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
183 Access e x -> access x `liftM` toJS' e
184 Remove e x -> remove x `liftM` toJS' e
185 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
186 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
187 setField fs' `liftM` toJS' e
188 Record fs -> makeRecord fs
189 Binop op e1 e2 -> binop op e1 e2
191 Lambda p e@(L s _) -> liftM fastFunc (toJS' body)
192 where
193 fastFunc body
194 | length args < 2 || length args > 9 =
195 foldr (\arg bod -> jsFunc arg (ret bod)) body args
196 | otherwise =
197 "F" ++ show (length args) ++ parens (jsFunc (commaSep args) (ret 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 -> (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,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 pattern <- case value of
302 Right (Boolean True) -> return "true"
303 Right (Boolean False) -> return "false"
304 Right lit -> toJS lit
305 Left name -> return . quoted $ case List.elemIndices '.' name of
306 [] -> name
307 is -> drop (last is + 1) name
308 return $ concat [ "\ncase ", pattern, ":", 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 ])