git.iko.soy/elk
on 4bb23bc help sign in
elk/compiler/Gen/CompileToJS.hs
342 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 LetBoundVars
17import Rename (deprime)
18import Types.Types ( Type(RecordT) )
20showErr :: String -> String
21showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
22 where msg = show . concatMap (++"<br>") . lines $ err
23 body = "var T = Elm.Text(elm);\n\
24 \return { main : T.text(T.monospace(" ++ msg ++ ")) };"
26indent = concatMap f
27 where f '\n' = "\n "
28 f c = [c]
30internalImports =
31 [ ("N" , "Elm.Native"),
32 ("_N", "N.Utils(elm)"),
33 ("_L", "N.List(elm)"),
34 ("_E", "N.Error(elm)"),
35 ("_str", "N.JavaScript(elm).toString")
36 ]
38parens s = "(" ++ s ++ ")"
39brackets s = "{" ++ s ++ "}"
40jsObj = brackets . intercalate ", "
41jsList ss = "["++ intercalate "," ss ++"]"
42jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
43assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
44ret e = "\nreturn "++ e ++";"
45iff a b c = a ++ "?" ++ b ++ ":" ++ c
46quoted s = "'" ++ concatMap f s ++ "'"
47 where f '\n' = "\\n"
48 f '\'' = "\\'"
49 f '\t' = "\\t"
50 f '\"' = "\\\""
51 f '\\' = "\\\\"
52 f c = [c]
54globalAssign n e = "\n" ++ assign' n e ++ ";"
55assign' n e = n ++ " = " ++ e
57jsModule (Module names exports imports stmts) =
58 setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
59 where
60 modNames = if null names then ["Main"] else names
61 modName = intercalate "." modNames
62 includes = concatMap jsImport imports
63 body = stmtsToJS stmts
64 defs = assign "$op" "{}"
65 program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
66 setup ("elm":"Native":modNames) ++
67 assign "_" ("elm.Native." ++ modName ++ "||{}") ++
68 getExports exports stmts ++ setup ("elm":modNames) ++
69 ret (assign' ("elm." ++ modName) "_") ++ "\n"
70 setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
71 map (intercalate ".") . drop 2 . inits $ init modNames
72 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
74getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
75 where exNames n = either derename id n `elem` names
76 exports | null names = concatMap get stmts
77 | otherwise = filter exNames (concatMap get stmts)
79 (fns,ops) = partitionEithers exports
81 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
82 fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
84 op = ("_.$op = "++) . jsObj $ map opPair ops
86 get' (FnDef x _ _) = Left x
87 get' (OpDef op _ _ _) = Right op
88 get s = case s of Definition d -> [ get' d ]
89 Datatype _ _ tcs -> map (Left . fst) tcs
90 ImportEvent _ _ x _ -> [ Left x ]
91 ExportEvent _ _ _ -> []
92 TypeAlias _ _ _ -> []
93 TypeAnnotation _ _ -> []
96jsImport (modul, how) =
97 case how of
98 As name -> assign name ("Elm." ++ modul ++ parens "elm")
99 Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
100 "; for(var k in _){if(k in hiding)continue;" ++
101 "eval('var '+k+'=_[\"'+k+'\"]')}"
102 Importing vs -> include ++ "\nvar " ++ intercalate ", " (map def vs) ++ ";"
103 where
104 imprt v = assign' v ("_." ++ v)
105 def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
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 (vars ++ concat program)
125 where
126 vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
127 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
128 valueOf s = case s of
129 Datatype _ _ _ -> 1
130 ImportEvent _ _ _ _ -> 2
131 Definition (FnDef f [] _) ->
132 if derename f == "main" then 5 else 4
133 Definition _ -> 3
134 ExportEvent _ _ _ -> 6
135 TypeAlias _ _ _ -> 0
136 TypeAnnotation _ _ -> 0
138class ToJS a where
139 toJS :: a -> GuidCounter String
141instance ToJS Def where
142 toJS (FnDef x [] e) = assign' x `liftM` toJS' e
143 toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
144 where 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.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 $ parens (intercalate ", " ds ++ ", " ++ 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 (match',stmt) <- case (match,e) of
282 (Match name _ _, C _ _ (Var x)) ->
283 return (matchSubst [(name,x)] match, Nothing)
284 (Match name _ _, _) ->
285 return (match, Just (name ++ " = " ++ e'))
286 _ -> return (match, Nothing)
287 matches <- matchToJS span match'
288 return $ case stmt of
289 Nothing -> matches
290 Just exp -> parens (exp ++ ", " ++ matches)
292matchToJS span match =
293 let sqnc e1 e2 = parens ("e=" ++ e1 ++ ":null,e!==null?e:" ++ e2)
294 in case match of
295 Match name clauses def ->
296 do cases <- intercalate ":" `liftM` mapM (clauseToJS span name) clauses
297 finally <- matchToJS span def
298 return (sqnc cases finally)
299 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
300 Break -> return "null"
301 Other e -> toJS' e
302 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
303 where dropEnd acc [] = acc
304 dropEnd acc (m:ms) =
305 case m of
306 Other _ -> acc ++ [m]
307 _ -> dropEnd (acc ++ [m]) ms
310clauseToJS span var (Clause name vars e) = do
311 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
312 s <- matchToJS span $ matchSubst (zip vars vars') e
313 return $ concat [ var, ".ctor===", quoted name, "?", s ]
315jsNil = "_L.Nil"
316jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
317jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
318jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
320binop (o:p) e1 e2
321 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
322 | otherwise =
323 let ops = ["+","-","*","/","&&","||"] in
324 case o:p of
325 "::" -> jsCons e1 e2
326 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
327 "$" -> e1 ++ parens e2
328 "<|" -> e1 ++ parens e2
329 "|>" -> e2 ++ parens e1
330 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
331 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
332 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
333 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
334 "<" -> jsCompare e1 e2 "==='LT'"
335 ">" -> jsCompare e1 e2 "==='GT'"
336 "<=" -> jsCompare e1 e2 "!=='GT'"
337 ">=" -> jsCompare e1 e2 "!=='LT'"
338 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
339 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
340 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
341 | otherwise -> concat [ "$op['", o:p, "']"
342 , parens e1, parens e2 ]