git.iko.soy/elk
on bbb2b2a help sign in
elk/compiler/Gen/CompileToJS.hs
337 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
10import Data.Maybe (maybeToList)
12import Ast
13import Located
14import Rename (derename)
15import Cases
16import Guid
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 ++";"
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 _ _) = Just (Left x)
86 get' (OpDef op _ _ _) = Just (Right op)
87 get' (TypeAnnotation _ _) = Nothing
88 get s = case s of Definition d -> maybeToList (get' d)
89 Datatype _ _ tcs -> map (Left . fst) tcs
90 ImportEvent _ _ x _ -> [ Left x ]
91 ExportEvent _ _ _ -> []
92 TypeAlias _ _ _ -> []
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 (TypeAnnotation _ _) -> 0
133 Definition _ -> 3
134 ExportEvent _ _ _ -> 6
135 TypeAlias _ _ _ -> 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)
151 toJS (TypeAnnotation _ _) = return ""
154instance ToJS Statement where
155 toJS stmt =
156 case stmt of
157 Definition d -> toJS d
158 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
159 where toDef (name,args) =
160 let vars = map (('a':) . show) [1..length args] in
161 Definition . FnDef name vars . notLocated $
162 Data (derename name) (map (notLocated . Var) vars)
163 ImportEvent js base elm _ ->
164 do v <- toJS' base
165 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
166 , "\ndocument.addEventListener('", js
167 , "_' + elm.id, function(e) { elm.notify(", elm
168 , ".id, e.value); });" ]
169 ExportEvent js elm _ ->
170 return $ concat [ "\nlift(function(v) { "
171 , "var e = document.createEvent('Event');"
172 , "e.initEvent('", js, "_' + elm.id, true, true);"
173 , "e.value = v;"
174 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
175 TypeAlias n _ t -> return ""
177toJS' :: CExpr -> GuidCounter String
178toJS' (L txt span expr) =
179 case expr of
180 MultiIf ps -> multiIfToJS span ps
181 Case e cases -> caseToJS span e cases
182 _ -> toJS expr
184remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
185addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
186setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
187 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
188access x e = e ++ "." ++ x
189makeRecord kvs = record `liftM` collect kvs
190 where
191 combine r (k,v) = Map.insertWith (++) k v r
192 collect = liftM (foldl' combine Map.empty) . mapM prep
193 prep (k, as, e@(L t s _)) =
194 do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)
195 return (k,[v])
196 fields fs =
197 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
198 hidden = fields . map (second jsList) .
199 filter (not . null . snd) . Map.toList . Map.map tail
200 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
203instance ToJS Expr where
204 toJS expr =
205 case expr of
206 Var x -> return $ x
207 Chr c -> return $ quoted [c]
208 Str s -> return $ "_str" ++ parens (quoted s)
209 IntNum n -> return $ show n
210 FloatNum n -> return $ show n
211 Boolean b -> return $ if b then "true" else "false"
212 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
213 Access e x -> access x `liftM` toJS' e
214 Remove e x -> remove x `liftM` toJS' e
215 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
216 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
217 setField fs' `liftM` toJS' e
218 Record fs -> makeRecord fs
219 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
221 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
223 App e1 e2 -> jsApp e1 e2
224 Let defs e -> jsLet defs e
225 Data name es ->
226 do fs <- mapM toJS' es
227 return $ case name of
228 "Nil" -> jsNil
229 "Cons" -> jsCons (head fs) ((head . tail) fs)
230 _ -> jsObj $ ("ctor:" ++ show name) : fields
231 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
233 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
234 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
235 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
237jsApp e1 e2 =
238 do f <- toJS' func
239 as <- mapM toJS' args
240 return $ case as of
241 [a] -> f ++ parens a
242 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
243 where
244 (func, args) = go [e2] e1
245 go args e =
246 case e of
247 (L _ _ (App e1 e2)) -> go (e2 : args) e1
248 _ -> (e, args)
250formatMarkdown = concatMap f
251 where f '\'' = "\\'"
252 f '\n' = "\\n"
253 f '"' = "\""
254 f c = [c]
256multiIfToJS span ps =
257 case last ps of
258 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
259 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
260 where
261 format base ps =
262 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
263 f (b,e) = do b' <- toJS' b
264 e' <- toJS' e
265 return (b' ++ " ? " ++ e')
267jsLet defs e' = do ds <- jsDefs defs
268 e <- toJS' e'
269 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
270 where
271 jsDefs defs = mapM toJS (sortBy f defs)
272 f a b = compare (valueOf a) (valueOf b)
273 valueOf (FnDef _ [] _) = 2
274 valueOf (FnDef _ _ _) = 1
275 valueOf (OpDef _ _ _ _) = 1
276 valueOf (TypeAnnotation _ _) = 0
278caseToJS span e ps = do
279 match <- caseToMatch ps
280 e' <- toJS' e
281 let (match',stmt) = case (match,e) of
282 (Match name _ _, L _ _ (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 "|>" -> e2 ++ parens e1
325 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
326 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
327 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
328 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
329 "<" -> jsCompare e1 e2 "==='LT'"
330 ">" -> jsCompare e1 e2 "==='GT'"
331 "<=" -> jsCompare e1 e2 "!=='GT'"
332 ">=" -> jsCompare e1 e2 "!=='LT'"
333 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
334 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
335 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
336 | otherwise -> concat [ "$op['", o:p, "']"
337 , parens e1, parens e2 ]