git.iko.soy/elk
on 5f1e3bd help sign in
elk/compiler/Gen/CompileToJS.hs
341 lines 14 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 -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` 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 "" (combineDefs ds ++ ret e) ++ "()"
272 where
273 combineDefs = concatMap (\def -> "\nvar " ++ def ++ ";")
274 jsDefs defs = mapM toJS (sortBy f defs)
275 f a b = compare (valueOf a) (valueOf b)
276 valueOf (FnDef _ args _) = min 1 (length args)
277 valueOf (OpDef _ _ _ _) = 1
279caseToJS span e ps = do
280 match <- caseToMatch ps
281 e' <- toJS' e
282 let (match',stmt) = case (match,e) of
283 (Match name _ _, C _ _ (Var x)) -> (matchSubst [(name,x)] match, Nothing)
284 (Match name _ _, _) -> (match, Just (name ++ " = " ++ e'))
285 _ -> (match, Nothing)
286 matches <- matchToJS span match'
287 let enclose body = "function(){ " ++ body ++ " }()"
288 return . enclose $ case stmt of
289 Nothing -> matches
290 Just exp -> "\nvar " ++ exp ++ ";" ++ matches
292matchToJS span match =
293 case match of
294 Match name clauses def ->
295 do cases <- concat `liftM` mapM (clauseToJS span name) clauses
296 finally <- matchToJS span def
297 return $ concat [ "\nswitch(", name, ".ctor){", indent cases, "\n}", finally ]
298 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
299 Break -> return "break;"
300 Other e -> ret `liftM` toJS' e
301 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
302 where
303 dropEnd acc [] = acc
304 dropEnd acc (m:ms) =
305 case m of
306 Other _ -> acc ++ [m]
307 _ -> dropEnd (acc ++ [m]) ms
309clauseToJS span var (Clause name vars e) = do
310 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
311 s <- matchToJS span $ matchSubst (zip vars vars') e
312 return $ concat [ "\ncase ", quoted name, ":", 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 ++ ").ctor" ++ op)
319binop (o:p) e1 e2
320 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
321 | otherwise =
322 let ops = ["+","-","*","/","&&","||"] in
323 case o:p of
324 "::" -> jsCons e1 e2
325 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
326 "$" -> e1 ++ parens e2
327 "<|" -> e1 ++ parens e2
328 "|>" -> e2 ++ parens e1
329 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
330 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
331 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
332 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
333 "<" -> jsCompare e1 e2 "==='LT'"
334 ">" -> jsCompare e1 e2 "==='GT'"
335 "<=" -> jsCompare e1 e2 "!=='GT'"
336 ">=" -> jsCompare e1 e2 "!=='LT'"
337 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
338 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
339 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
340 | otherwise -> concat [ "$op['", o:p, "']"
341 , parens e1, parens e2 ]