git.iko.soy/elk
on cbaff88 help sign in
elk/compiler/Generate/JavaScript.hs
361 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 [ "\nvar " ++ usefulFuncs ++ ";"
64 , concatMap jsImport (imports modul)
65 , concat foreignImport
66 , assign "_op" "{}"
67 , body
68 , concatMap exportEvent $ foreignExports modul
69 , jsExports
70 ]
71 setup names = concatMap (\n -> globalAssign n $ n ++ " || {}") .
72 map dotSep . drop 2 . List.inits $ init names
73 usefulFuncs = commaSep (map (uncurry assign') (internalImports modName))
75 jsExports = setup ("elm" : names modul) ++
76 ret (assign' ("elm." ++ modName) (brackets exs))
77 where
78 exs = indent . commaSep . concatMap pair $ "_op" : exports modul
79 pair x | isOp x = []
80 | otherwise = ["\n" ++ x ++ " : " ++ x]
83 importEvent (js,base,elm,_) =
84 do v <- toJS' base
85 return $ concat [ "\nvar " ++ elm ++ "=Signal.constant(" ++ v ++ ");"
86 , "\ndocument.addEventListener('", js
87 , "_' + elm.id, function(e) { elm.notify(", elm
88 , ".id, e.value); });" ]
90 exportEvent (js,elm,_) =
91 concat [ "\nA2( Signal.lift, function(v) { "
92 , "var e = document.createEvent('Event');"
93 , "e.initEvent('", js, "_' + elm.id, true, true);"
94 , "e.value = v;"
95 , "document.dispatchEvent(e); return v; }, ", elm, ");" ]
97jsImport (modul, method) =
98 concat $ zipWith3 (\s n v -> s ++ assign' n v ++ ";") starters subnames values
99 where
100 starters = "\nvar " : repeat "\n"
101 values = map (\name -> name ++ " || {}") (init subnames) ++
102 ["Elm." ++ modul ++ parens "elm"]
103 subnames = map dotSep . tail . List.inits $ split modul
105 split names = case go [] names of
106 (name, []) -> [name]
107 (name, ns) -> name : split ns
108 go name str = case str of
109 '.':rest -> (reverse name, rest)
110 c:rest -> go (c:name) rest
111 [] -> (reverse name, [])
114class ToJS a where
115 toJS :: a -> Unique String
118instance ToJS (Def t v) where
120 -- TODO: Make this handle patterns besides plain variables
121 toJS (Def (PVar x) e)
122 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
123 | otherwise = assign x `liftM` toJS' e
125 toJS (Def pattern e@(L s _)) =
126 do n <- guid
127 let x = "_" ++ show n
128 var = L s . Var
129 toDef y = Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
130 stmt <- assign x `liftM` toJS' e
131 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
132 return (stmt ++ vars)
134 toJS (TypeAnnotation _ _) = return ""
137instance ToJS a => ToJS [a] where
138 toJS xs = concat `liftM` mapM toJS xs
140toJS' :: LExpr t v -> Unique String
141toJS' (L span expr) =
142 case expr of
143 MultiIf ps -> multiIfToJS span ps
144 Case e cases -> caseToJS span e cases
145 _ -> toJS expr
147remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
148addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
149setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
150 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
151access x e = e ++ "." ++ x
152makeRecord kvs = record `liftM` collect kvs
153 where
154 combine r (k,v) = Map.insertWith (++) k v r
155 collect = liftM (List.foldl' combine Map.empty) . mapM prep
156 prep (k, e) =
157 do v <- toJS' e
158 return (k, [v])
159 fields fs =
160 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
161 hidden = fields . map (second jsList) .
162 filter (not . null . snd) . Map.toList . Map.map tail
163 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
166instance ToJS Literal where
167 toJS lit =
168 case lit of
169 Chr c -> return $ quoted [c]
170 Str s -> return $ "_str" ++ parens (quoted s)
171 IntNum n -> return $ show n
172 FloatNum n -> return $ show n
173 Boolean b -> return $ if b then "true" else "false"
176instance ToJS (Expr t v) where
177 toJS expr =
178 case expr of
179 Var x -> return x
180 Literal lit -> toJS lit
181 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
182 Access e x -> access x `liftM` toJS' e
183 Remove e x -> remove x `liftM` toJS' e
184 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
185 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
186 setField fs' `liftM` toJS' e
187 Record fs -> makeRecord fs
188 Binop op e1 e2 -> binop op e1 e2
190 Lambda p e@(L s _) -> liftM fastFunc (toJS' body)
191 where
192 fastFunc body
193 | length args < 2 || length args > 9 =
194 foldr (\arg bod -> jsFunc arg (ret bod)) body args
195 | otherwise =
196 "F" ++ show (length args) ++ parens (jsFunc (commaSep args) (ret body))
198 (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
200 depattern (pattern,n) (args, body) =
201 case pattern of
202 PVar x -> (x : args, body)
203 _ -> let arg = "arg" ++ show n
204 in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
206 (patterns, innerBody) = collect [p] e
208 collect patterns lexpr@(L _ expr) =
209 case expr of
210 Lambda p e -> collect (p:patterns) e
211 _ -> (patterns, lexpr)
213 App e1 e2 -> jsApp e1 e2
214 Let defs e -> jsLet $ SD.flattenLets defs e
216 ExplicitList es ->
217 do es' <- mapM toJS' es
218 return $ "_J.toList" ++ parens (jsList es')
220 Data name es ->
221 do fs <- mapM toJS' es
222 return $ case name of
223 "[]" -> jsNil
224 "::" -> jsCons (head fs) ((head . tail) fs)
225 _ -> jsObj $ ("ctor:" ++ show name) : fields
226 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
228 Markdown doc -> return $ "Text.text('" ++ pad ++ md ++ pad ++ "')"
229 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
230 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
232jsApp e1 e2 =
233 do f <- toJS' func
234 as <- mapM toJS' args
235 return $ case as of
236 [a] -> f ++ parens a
237 _ -> "A" ++ show (length as) ++ parens (commaSep (f:as))
238 where
239 (func, args) = go [e2] e1
240 go args e =
241 case e of
242 (L _ (App e1 e2)) -> go (e2 : args) e1
243 _ -> (e, args)
245formatMarkdown = concatMap f
246 where f '\'' = "\\'"
247 f '\n' = "\\n"
248 f '"' = "\""
249 f c = [c]
251multiIfToJS span ps =
252 case last ps of
253 (L _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
254 _ -> format ("_E.If" ++ parens ("$moduleName," ++ quoted (show span))) ps
255 where
256 format base ps =
257 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
258 f (b,e) = do b' <- toJS' b
259 e' <- toJS' e
260 return (b' ++ " ? " ++ e')
262jsLet (defs,e') = do ds <- mapM toJS defs
263 e <- toJS' e'
264 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
266caseToJS span e ps = do
267 (tempVar,match) <- caseToMatch ps
268 e' <- toJS' e
269 let (match',stmt) = case e of
270 L _ (Var x) -> (matchSubst [(tempVar,x)] match, "")
271 _ -> (match, assign tempVar e')
272 matches <- matchToJS span match'
273 return $ jsFunc "" (stmt ++ matches) ++ "()"
275matchToJS span match =
276 case match of
277 Match name clauses def ->
278 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
279 finally <- matchToJS span def
280 let isLiteral p = case p of
281 Clause (Right _) _ _ -> True
282 _ -> False
283 access = if any isLiteral clauses then "" else ".ctor"
284 return $ concat [ "\nswitch (", name, access, ") {"
285 , indent cases, "\n}", finally ]
286 Fail -> return ("_E.Case" ++ parens ("$moduleName," ++ quoted (show span)))
287 Break -> return "break;"
288 Other e -> ret `liftM` toJS' e
289 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
290 where
291 dropEnd acc [] = acc
292 dropEnd acc (m:ms) =
293 case m of
294 Other _ -> acc ++ [m]
295 _ -> dropEnd (acc ++ [m]) ms
297clauseToJS span var (Clause value vars e) = do
298 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
299 s <- matchToJS span $ matchSubst (zip vars vars') e
300 pattern <- case value of
301 Right (Boolean True) -> return "true"
302 Right (Boolean False) -> return "false"
303 Right lit -> toJS lit
304 Left name -> return . quoted $ case List.elemIndices '.' name of
305 [] -> name
306 is -> drop (last is + 1) name
307 return $ concat [ "\ncase ", pattern, ":", indent s ]
309jsNil = "_L.Nil"
310jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
311jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
312jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
315binop op e1 e2
316 | op == "Basics.." =
317 do ss <- mapM toJS' (e1 : collect [] e2)
318 return . jsFunc "$" . ret $ apply "$" ss
319 | op == "Basics.<|" =
320 do arg <- toJS' e2
321 funcs <- mapM toJS' (collect [] e1)
322 return (apply arg funcs)
323 | otherwise =
324 binopNormal op `liftM` toJS' e1 `ap` toJS' e2
325 where
326 apply = foldr (\f arg-> f ++ parens arg)
328 collect es e =
329 case e of
330 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
331 _ -> es ++ [e]
333binopNormal op s1 s2 =
334 case Map.lookup op opDict of
335 Just e -> e
336 Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, s1, s2 ])
337 where
338 func | isOp op' = "_op['" ++ op' ++ "']"
339 | otherwise = op'
340 (prefix, op') = case List.elemIndices '.' op of
341 [] -> ("", op)
342 xs -> splitAt (last xs + 1) op
344 opDict = Map.fromList $ basics ++
345 [ ("::", jsCons s1 s2)
346 , ("List.++", "_L.append" ++ parens (s1 ++ "," ++ s2)) ]
348 ops = pow : map (\op -> (op, parens (s1 ++ op ++ s2))) ["+","-","*","/","&&","||"]
349 where pow = ("^" , "Math.pow(" ++ s1 ++ "," ++ s2 ++ ")")
351 basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
352 (ops ++ [ ("<|", s1 ++ parens s2)
353 , ("|>", s2 ++ parens s1)
354 , ("==", "_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
355 , ("/=", "!_N.eq(" ++ s1 ++ "," ++ s2 ++ ")")
356 , ("<" , jsCompare s1 s2 "<0")
357 , (">" , jsCompare s1 s2 ">0")
358 , ("<=", jsCompare s1 s2 "<1")
359 , (">=", jsCompare s1 s2 ">-1")
360 , ("div", parens (s1 ++ "/" ++ s2 ++ "|0"))
361 ])