git.iko.soy/elk
on a2e9bef help sign in
elk/compiler/Generate/JavaScript.hs
355 lines 14 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 Data.List (intercalate,sortBy,inits,foldl')
7import qualified Data.Map as Map
8import Data.Either (partitionEithers)
9import qualified Text.Pandoc as Pan
10import Data.Maybe (maybeToList)
12import Unique
13import Generate.Cases
14import SourceSyntax.Everything hiding (parens)
15import Types.Types ( Type(RecordT) )
17showErr :: String -> String
18showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
19 where msg = show . concatMap (++"<br>") . lines $ err
20 body = "var T = Elm.Text(elm);\n\
21 \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
23indent = concatMap f
24 where f '\n' = "\n "
25 f c = [c]
27internalImports =
28 [ ("N" , "Elm.Native"),
29 ("_N", "N.Utils(elm)"),
30 ("_L", "N.List(elm)"),
31 ("_E", "N.Error(elm)"),
32 ("_J", "N.JavaScript(elm)"),
33 ("_str", "_J.toString")
34 ]
36parens s = "(" ++ s ++ ")"
37brackets s = "{" ++ s ++ "}"
38jsObj = brackets . intercalate ", "
39jsList ss = "["++ intercalate "," ss ++"]"
40jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
41assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
42ret e = "\nreturn "++ e ++";"
43quoted s = "'" ++ concatMap f s ++ "'"
44 where f '\n' = "\\n"
45 f '\'' = "\\'"
46 f '\t' = "\\t"
47 f '\"' = "\\\""
48 f '\\' = "\\\\"
49 f c = [c]
51globalAssign n e = "\n" ++ assign' n e ++ ";"
52assign' n e = n ++ " = " ++ e
54jsModule (Module names exports imports stmts) =
55 setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
56 where
57 modNames = if null names then ["Main"] else names
58 modName = intercalate "." modNames
59 includes = concatMap jsImport imports
60 body = stmtsToJS stmts
61 defs = assign "$op" "{}"
62 program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
63 setup ("elm":"Native":modNames) ++
64 assign "_" ("elm.Native." ++ modName ++ "||{}") ++
65 getExports exports stmts ++ setup ("elm":modNames) ++
66 ret (assign' ("elm." ++ modName) "_") ++ "\n"
67 setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
68 map (intercalate ".") . drop 2 . inits $ init modNames
69 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
71getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
72 where exNames n = either derename id n `elem` names
73 exports | null names = concatMap get stmts
74 | otherwise = filter exNames (concatMap get stmts)
76 (fns,ops) = partitionEithers exports
78 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
79 fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
81 op = ("_.$op = "++) . jsObj $ map opPair ops
83 get' (FnDef x _ _) = Just (Left x)
84 get' (OpDef op _ _ _) = Just (Right op)
85 get' (TypeAnnotation _ _) = Nothing
86 get s = case s of Definition d -> maybeToList (get' d)
87 Datatype _ _ tcs -> map (Left . fst) tcs
88 ImportEvent _ _ x _ -> [ Left x ]
89 ExportEvent _ _ _ -> []
90 TypeAlias _ _ _ -> []
93jsImport (modul, how) =
94 case how of
95 As name -> assign name ("Elm." ++ modul ++ parens "elm")
96 Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
97 "; for(var k in _){if(k in hiding)continue;" ++
98 "eval('var '+k+'=_[\"'+k+'\"]')}"
99 Importing vs -> include ++ named
100 where
101 imprt v = assign' v ("_." ++ v)
102 def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
103 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
104 where
105 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
106 setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
107 where
108 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
109 subnames = map (intercalate ".") . tail . inits . init . split
110 split names = case go [] names of
111 (name, []) -> [name]
112 (name, ns) -> name : split ns
113 go name str = case str of
114 '.':rest -> (reverse name, rest)
115 c:rest -> go (c:name) rest
116 [] -> (reverse name, [])
120stmtsToJS :: [Declaration t v] -> String
121stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
122 return (concat program)
123 where
124 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
125 valueOf s = case s of
126 Datatype _ _ _ -> 1
127 ImportEvent _ _ _ _ -> 2
128 Definition (FnDef f [] _) ->
129 if derename f == "main" then 5 else 4
130 Definition (TypeAnnotation _ _) -> 0
131 Definition _ -> 3
132 ExportEvent _ _ _ -> 6
133 TypeAlias _ _ _ -> 0
135class ToJS a where
136 toJS :: a -> Unique String
138instance ToJS (Def t v) where
139 toJS (FnDef x [] e) = assign x `liftM` toJS' e
140 toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e
141 where
142 func body = jsFunc (intercalate ", " as) (ret body)
143 wrapper e | length as == 1 = e
144 | otherwise = 'F' : show (length as) ++ parens e
145 toJS (OpDef op a1 a2 e) =
146 do body <- toJS' e
147 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
148 return (globalAssign ("$op['" ++ op ++ "']") func)
149 toJS (TypeAnnotation _ _) = return ""
152instance ToJS (Declaration t v) where
153 toJS stmt =
154 case stmt of
155 Definition d -> toJS d
156 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
157 where toDef (name,args) =
158 let vars = map (('a':) . show) [1..length args] in
159 Definition . FnDef name vars . none $
160 Data (derename name) (map (none . Var) vars)
161 ImportEvent js base elm _ ->
162 do v <- toJS' base
163 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
164 , "\ndocument.addEventListener('", js
165 , "_' + elm.id, function(e) { elm.notify(", elm
166 , ".id, e.value); });" ]
167 ExportEvent js elm _ ->
168 return $ concat [ "\nlift(function(v) { "
169 , "var e = document.createEvent('Event');"
170 , "e.initEvent('", js, "_' + elm.id, true, true);"
171 , "e.value = v;"
172 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
173 TypeAlias n _ t -> return ""
175toJS' :: LExpr t v -> Unique String
176toJS' (L txt span expr) =
177 case expr of
178 MultiIf ps -> multiIfToJS span ps
179 Case e cases -> caseToJS span e cases
180 _ -> toJS expr
182remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
183addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
184setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
185 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
186access x e = e ++ "." ++ x
187makeRecord kvs = record `liftM` collect kvs
188 where
189 combine r (k,v) = Map.insertWith (++) k v r
190 collect = liftM (foldl' combine Map.empty) . mapM prep
191 prep (k, as, e@(L t s _)) =
192 do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)
193 return (k,[v])
194 fields fs =
195 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
196 hidden = fields . map (second jsList) .
197 filter (not . null . snd) . Map.toList . Map.map tail
198 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
201instance ToJS Literal where
202 toJS lit =
203 case lit of
204 Chr c -> return $ quoted [c]
205 Str s -> return $ "_str" ++ parens (quoted s)
206 IntNum n -> return $ show n
207 FloatNum n -> return $ show n
208 Boolean b -> return $ if b then "true" else "false"
211instance ToJS (Expr t v) where
212 toJS expr =
213 case expr of
214 Var x -> return x
215 Literal lit -> toJS lit
216 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
217 Access e x -> access x `liftM` toJS' e
218 Remove e x -> remove x `liftM` toJS' e
219 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
220 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
221 setField fs' `liftM` toJS' e
222 Record fs -> makeRecord fs
223 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
225 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
227 App e1 e2 -> jsApp e1 e2
228 Let defs e -> jsLet defs e
230 ExplicitList es ->
231 do es' <- mapM toJS' es
232 return $ "_J.toList" ++ parens (jsList es')
234 Data name es ->
235 do fs <- mapM toJS' es
236 return $ case name of
237 "[]" -> jsNil
238 "::" -> jsCons (head fs) ((head . tail) fs)
239 _ -> jsObj $ ("ctor:" ++ show name) : fields
240 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
242 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
243 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
244 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
246jsApp e1 e2 =
247 do f <- toJS' func
248 as <- mapM toJS' args
249 return $ case as of
250 [a] -> f ++ parens a
251 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
252 where
253 (func, args) = go [e2] e1
254 go args e =
255 case e of
256 (L _ _ (App e1 e2)) -> go (e2 : args) e1
257 _ -> (e, args)
259formatMarkdown = concatMap f
260 where f '\'' = "\\'"
261 f '\n' = "\\n"
262 f '"' = "\""
263 f c = [c]
265multiIfToJS span ps =
266 case last ps of
267 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
268 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
269 where
270 format base ps =
271 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
272 f (b,e) = do b' <- toJS' b
273 e' <- toJS' e
274 return (b' ++ " ? " ++ e')
276jsLet defs e' = do ds <- jsDefs defs
277 e <- toJS' e'
278 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
279 where
280 jsDefs defs = mapM toJS (sortBy f defs)
281 f a b = compare (valueOf a) (valueOf b)
282 valueOf (FnDef _ [] _) = 2
283 valueOf (FnDef _ _ _) = 1
284 valueOf (OpDef _ _ _ _) = 1
285 valueOf (TypeAnnotation _ _) = 0
287caseToJS span e ps = do
288 match <- caseToMatch ps
289 e' <- toJS' e
290 let (match',stmt) = case (match,e) of
291 (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
292 (Match name _ _, _) -> (match, assign name e')
293 _ -> (match, "")
294 matches <- matchToJS span match'
295 return $ "function(){ " ++ stmt ++ matches ++ " }()"
297matchToJS span match =
298 case match of
299 Match name clauses def ->
300 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
301 finally <- matchToJS span def
302 let isLiteral p = case p of
303 Clause (Right _) _ _ -> True
304 _ -> False
305 access = if any isLiteral clauses then "" else ".ctor"
306 return $ concat [ "\nswitch (", name, access, ") {"
307 , indent cases, "\n}", finally ]
308 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
309 Break -> return "break;"
310 Other e -> ret `liftM` toJS' e
311 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
312 where
313 dropEnd acc [] = acc
314 dropEnd acc (m:ms) =
315 case m of
316 Other _ -> acc ++ [m]
317 _ -> dropEnd (acc ++ [m]) ms
319clauseToJS span var (Clause value vars e) = do
320 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
321 s <- matchToJS span $ matchSubst (zip vars vars') e
322 return $ concat [ "\ncase ", case value of
323 Left name -> quoted name
324 Right (Boolean True) -> "true"
325 Right (Boolean False) -> "false"
326 Right lit -> show lit
327 , ":", indent s ]
329jsNil = "_L.Nil"
330jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
331jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
332jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
334binop (o:p) e1 e2
335 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
336 | otherwise =
337 let ops = ["+","-","*","/","&&","||"] in
338 case o:p of
339 "::" -> jsCons e1 e2
340 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
341 "<|" -> e1 ++ parens e2
342 "|>" -> e2 ++ parens e1
343 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
344 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
345 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
346 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
347 "<" -> jsCompare e1 e2 "==='LT'"
348 ">" -> jsCompare e1 e2 "==='GT'"
349 "<=" -> jsCompare e1 e2 "!=='GT'"
350 ">=" -> jsCompare e1 e2 "!=='LT'"
351 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
352 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
353 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
354 | otherwise -> concat [ "$op['", o:p, "']"
355 , parens e1, parens e2 ]