git.iko.soy/elk
on a56efd8 help sign in
elk/compiler/Generate/JavaScript.hs
349 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 , concatMap exportEvent $ foreignExports modul
75 , assign "_op" "{}"
76 , body
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 $ "_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 ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
94 , "\ndocument.addEventListener('", js
95 , "_' + elm.id, function(e) { elm.notify(", elm
96 , ".id, e.value); });" ]
98 exportEvent (js,elm,_) =
99 concat [ "\nlift(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('" ++ 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 match <- caseToMatch ps
274 e' <- toJS' e
275 let (match',stmt) = case (match,e) of
276 (Match name _ _, L _ (Var x)) -> (matchSubst [(name,deprime x)] match, "")
277 (Match name _ _, _) -> (match, assign name e')
278 _ -> (match, "")
279 matches <- matchToJS span match'
280 return $ "function(){ " ++ 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 (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 Left name -> quoted name
309 Right (Boolean True) -> "true"
310 Right (Boolean False) -> "false"
311 Right lit -> show lit
312 , ":", indent s ]
314jsNil = "_L.Nil"
315jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
316jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
317jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ")" ++ op)
320binop op e1 e2 =
321 case Map.lookup op opDict of
322 Just e -> e
323 Nothing -> "A2" ++ parens (commaSep [ prefix ++ func, e1, e2 ])
324 where
325 func | isOp op' = "_op['" ++ op' ++ "']"
326 | otherwise = op'
327 (prefix, op') = case List.elemIndices '.' op of
328 [] -> ("", op)
329 xs -> splitAt (last xs + 1) op
330 where
331 opDict = Map.fromList $ basics ++
332 [ ("::", jsCons e1 e2)
333 , ("List.++", "_L.append" ++ parens (e1 ++ "," ++ e2)) ]
335 ops = pow : map (\op -> (op, parens (e1 ++ op ++ e2))) ["+","-","*","/","&&","||"]
336 where pow = ("^" , "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")")
338 basics = ops ++ map (\(op,e) -> ("Basics." ++ op, e))
339 (ops ++ [ ("<|", e1 ++ parens e2)
340 , ("|>", e2 ++ parens e1)
341 , ("." , jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x"))
342 , ("==", "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")")
343 , ("/=", "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")")
344 , ("<" , jsCompare e1 e2 "<0")
345 , (">" , jsCompare e1 e2 ">0")
346 , ("<=", jsCompare e1 e2 "<1")
347 , (">=", jsCompare e1 e2 ">-1")
348 , ("div", parens (e1 ++ "/" ++ e2 ++ "|0"))
349 ])