git.iko.soy/elk
on de4e9ac help sign in
elk/compiler/Gen/CompileToJS.hs
338 lines 13 kB history raw
1module CompileToJS (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
11import Ast
12import Context
13import Rename (derename)
14import Cases
15import Guid
16import Rename (deprime)
17import Types.Types ( Type(RecordT) )
19showErr :: String -> String
20showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
21 where msg = show . concatMap (++"<br>") . lines $ err
22 body = "var T = Elm.Text(elm);\n\
23 \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
25indent = concatMap f
26 where f '\n' = "\n "
27 f c = [c]
29internalImports =
30 [ ("N" , "Elm.Native"),
31 ("_N", "N.Utils(elm)"),
32 ("_L", "N.List(elm)"),
33 ("_E", "N.Error(elm)"),
34 ("_str", "N.JavaScript(elm).toString")
35 ]
37parens s = "(" ++ s ++ ")"
38brackets s = "{" ++ s ++ "}"
39jsObj = brackets . intercalate ", "
40jsList ss = "["++ intercalate "," ss ++"]"
41jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
42assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
43ret e = "\nreturn "++ e ++";"
44iff a b c = a ++ "?" ++ b ++ ":" ++ c
45quoted s = "'" ++ concatMap f s ++ "'"
46 where f '\n' = "\\n"
47 f '\'' = "\\'"
48 f '\t' = "\\t"
49 f '\"' = "\\\""
50 f '\\' = "\\\\"
51 f c = [c]
53globalAssign n e = "\n" ++ assign' n e ++ ";"
54assign' n e = n ++ " = " ++ e
56jsModule (Module names exports imports stmts) =
57 setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
58 where
59 modNames = if null names then ["Main"] else names
60 modName = intercalate "." modNames
61 includes = concatMap jsImport imports
62 body = stmtsToJS stmts
63 defs = assign "$op" "{}"
64 program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
65 setup ("elm":"Native":modNames) ++
66 assign "_" ("elm.Native." ++ modName ++ "||{}") ++
67 getExports exports stmts ++ setup ("elm":modNames) ++
68 ret (assign' ("elm." ++ modName) "_") ++ "\n"
69 setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
70 map (intercalate ".") . drop 2 . inits $ init modNames
71 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
73getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
74 where exNames n = either derename id n `elem` names
75 exports | null names = concatMap get stmts
76 | otherwise = filter exNames (concatMap get stmts)
78 (fns,ops) = partitionEithers exports
80 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
81 fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
83 op = ("_.$op = "++) . jsObj $ map opPair ops
85 get' (FnDef x _ _) = Left x
86 get' (OpDef op _ _ _) = Right op
87 get s = case s of Definition d -> [ get' d ]
88 Datatype _ _ tcs -> map (Left . fst) tcs
89 ImportEvent _ _ x _ -> [ Left x ]
90 ExportEvent _ _ _ -> []
91 TypeAlias _ _ _ -> []
92 TypeAnnotation _ _ -> []
95jsImport (modul, how) =
96 case how of
97 As name -> assign name ("Elm." ++ modul ++ parens "elm")
98 Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
99 "; for(var k in _){if(k in hiding)continue;" ++
100 "eval('var '+k+'=_[\"'+k+'\"]')}"
101 Importing vs -> include ++ named
102 where
103 imprt v = assign' v ("_." ++ v)
104 def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
105 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
106 where
107 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
108 setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
109 where
110 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
111 subnames = map (intercalate ".") . tail . inits . init . split
112 split names = case go [] names of
113 (name, []) -> [name]
114 (name, ns) -> name : split ns
115 go name str = case str of
116 '.':rest -> (reverse name, rest)
117 c:rest -> go (c:name) rest
118 [] -> (reverse name, [])
122stmtsToJS :: [Statement] -> String
123stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
124 return (concat program)
125 where
126 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
127 valueOf s = case s of
128 Datatype _ _ _ -> 1
129 ImportEvent _ _ _ _ -> 2
130 Definition (FnDef f [] _) ->
131 if derename f == "main" then 5 else 4
132 Definition _ -> 3
133 ExportEvent _ _ _ -> 6
134 TypeAlias _ _ _ -> 0
135 TypeAnnotation _ _ -> 0
137class ToJS a where
138 toJS :: a -> GuidCounter String
140instance ToJS Def where
141 toJS (FnDef x [] e) = assign x `liftM` toJS' e
142 toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e
143 where
144 func body = jsFunc (intercalate ", " as) (ret body)
145 wrapper e | length as == 1 = e
146 | otherwise = 'F' : show (length as) ++ parens e
147 toJS (OpDef op a1 a2 e) =
148 do body <- toJS' e
149 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
150 return (globalAssign ("$op['" ++ op ++ "']") func)
152instance ToJS Statement 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 . noContext $
160 Data (derename name) (map (noContext . 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 TypeAnnotation _ _ -> return ""
174 TypeAlias n _ t -> return ""
176toJS' :: CExpr -> GuidCounter String
177toJS' (C txt span expr) =
178 case expr of
179 MultiIf ps -> multiIfToJS span ps
180 Case e cases -> caseToJS span e cases
181 _ -> toJS expr
183remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
184addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
185setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
186 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
187access x e = e ++ "." ++ x
188makeRecord kvs = record `liftM` collect kvs
189 where
190 combine r (k,v) = Map.insertWith (++) k v r
191 collect = liftM (foldl' combine Map.empty) . mapM prep
192 prep (k, as, e@(C t s _)) =
193 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
194 return (k,[v])
195 fields fs =
196 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
197 hidden = fields . map (second jsList) .
198 filter (not . null . snd) . Map.toList . Map.map tail
199 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
202instance ToJS Expr where
203 toJS expr =
204 case expr of
205 Var x -> return $ x
206 Chr c -> return $ quoted [c]
207 Str s -> return $ "_str" ++ parens (quoted s)
208 IntNum n -> return $ show n
209 FloatNum n -> return $ show n
210 Boolean b -> return $ if b then "true" else "false"
211 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
212 Access e x -> access x `liftM` toJS' e
213 Remove e x -> remove x `liftM` toJS' e
214 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
215 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
216 setField fs' `liftM` toJS' e
217 Record fs -> makeRecord fs
218 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
220 If eb et ef ->
221 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
223 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
225 App e1 e2 -> jsApp e1 e2
226 Let defs e -> jsLet defs e
227 Data name es ->
228 do fs <- mapM toJS' es
229 return $ case name of
230 "Nil" -> jsNil
231 "Cons" -> jsCons (head fs) ((head . tail) fs)
232 _ -> jsObj $ ("ctor:" ++ show name) : fields
233 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
235 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
236 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
237 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
239jsApp e1 e2 =
240 do f <- toJS' func
241 as <- mapM toJS' args
242 return $ case as of
243 [a] -> f ++ parens a
244 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
245 where
246 (func, args) = go [e2] e1
247 go args e =
248 case e of
249 (C _ _ (App e1 e2)) -> go (e2 : args) e1
250 _ -> (e, args)
252formatMarkdown = concatMap f
253 where f '\'' = "\\'"
254 f '\n' = "\\n"
255 f '"' = "\""
256 f c = [c]
258multiIfToJS span ps =
259 case last ps of
260 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
261 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
262 where
263 format base ps =
264 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
265 f (b,e) = do b' <- toJS' b
266 e' <- toJS' e
267 return (b' ++ " ? " ++ e')
269jsLet defs e' = do ds <- jsDefs defs
270 e <- toJS' e'
271 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
272 where
273 jsDefs defs = mapM toJS (sortBy f defs)
274 f a b = compare (valueOf a) (valueOf b)
275 valueOf (FnDef _ args _) = min 1 (length args)
276 valueOf (OpDef _ _ _ _) = 1
278caseToJS span e ps = do
279 match <- caseToMatch ps
280 e' <- toJS' e
281 let (match',stmt) = case (match,e) of
282 (Match name _ _, C _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
283 (Match name _ _, _) -> (match, assign name e')
284 _ -> (match, "")
285 matches <- matchToJS span match'
286 return $ "function(){ " ++ stmt ++ matches ++ " }()"
288matchToJS span match =
289 case match of
290 Match name clauses def ->
291 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
292 finally <- matchToJS span def
293 return $ concat [ "\nswitch (", name, ".ctor) {",
294 indent cases, "\n}", finally ]
295 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
296 Break -> return "break;"
297 Other e -> ret `liftM` toJS' e
298 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
299 where
300 dropEnd acc [] = acc
301 dropEnd acc (m:ms) =
302 case m of
303 Other _ -> acc ++ [m]
304 _ -> dropEnd (acc ++ [m]) ms
306clauseToJS span var (Clause name vars e) = do
307 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
308 s <- matchToJS span $ matchSubst (zip vars vars') e
309 return $ concat [ "\ncase ", quoted name, ":", indent s ]
311jsNil = "_L.Nil"
312jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
313jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
314jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
316binop (o:p) e1 e2
317 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
318 | otherwise =
319 let ops = ["+","-","*","/","&&","||"] in
320 case o:p of
321 "::" -> jsCons e1 e2
322 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
323 "$" -> e1 ++ parens e2
324 "<|" -> e1 ++ parens e2
325 "|>" -> e2 ++ parens e1
326 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
327 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
328 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
329 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
330 "<" -> jsCompare e1 e2 "==='LT'"
331 ">" -> jsCompare e1 e2 "==='GT'"
332 "<=" -> jsCompare e1 e2 "!=='GT'"
333 ">=" -> jsCompare e1 e2 "!=='LT'"
334 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
335 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
336 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
337 | otherwise -> concat [ "$op['", o:p, "']"
338 , parens e1, parens e2 ]