git.iko.soy/elk
on 44fecef help sign in
elk/compiler/Gen/CompileToJS.hs
341 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 ++";"
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 _ _) = Just (Left x)
87 get' (OpDef op _ _ _) = Just (Right op)
88 get' (TypeAnnotation _ _) = Nothing
89 get s = case s of Definition d -> maybeToList (get' d)
90 Datatype _ _ tcs -> map (Left . fst) tcs
91 ImportEvent _ _ x _ -> [ Left x ]
92 ExportEvent _ _ _ -> []
93 TypeAlias _ _ _ -> []
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 ++ named
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 named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
107 where
108 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
109 setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
110 where
111 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
112 subnames = map (intercalate ".") . tail . inits . init . split
113 split names = case go [] names of
114 (name, []) -> [name]
115 (name, ns) -> name : split ns
116 go name str = case str of
117 '.':rest -> (reverse name, rest)
118 c:rest -> go (c:name) rest
119 [] -> (reverse name, [])
123stmtsToJS :: [Statement] -> String
124stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
125 return (concat program)
126 where
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 (TypeAnnotation _ _) -> 0
134 Definition _ -> 3
135 ExportEvent _ _ _ -> 6
136 TypeAlias _ _ _ -> 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
145 func body = jsFunc (intercalate ", " as) (ret body)
146 wrapper e | length as == 1 = e
147 | otherwise = 'F' : show (length as) ++ parens e
148 toJS (OpDef op a1 a2 e) =
149 do body <- toJS' e
150 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
151 return (globalAssign ("$op['" ++ op ++ "']") func)
152 toJS (TypeAnnotation _ _) = return ""
155instance ToJS Statement where
156 toJS stmt =
157 case stmt of
158 Definition d -> toJS d
159 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
160 where toDef (name,args) =
161 let vars = map (('a':) . show) [1..length args] in
162 Definition . FnDef name vars . notLocated $
163 Data (derename name) (map (notLocated . Var) vars)
164 ImportEvent js base elm _ ->
165 do v <- toJS' base
166 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
167 , "\ndocument.addEventListener('", js
168 , "_' + elm.id, function(e) { elm.notify(", elm
169 , ".id, e.value); });" ]
170 ExportEvent js elm _ ->
171 return $ concat [ "\nlift(function(v) { "
172 , "var e = document.createEvent('Event');"
173 , "e.initEvent('", js, "_' + elm.id, true, true);"
174 , "e.value = v;"
175 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
176 TypeAlias n _ t -> return ""
178toJS' :: CExpr -> GuidCounter String
179toJS' (L txt span expr) =
180 case expr of
181 MultiIf ps -> multiIfToJS span ps
182 Case e cases -> caseToJS span e cases
183 _ -> toJS expr
185remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
186addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
187setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
188 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
189access x e = e ++ "." ++ x
190makeRecord kvs = record `liftM` collect kvs
191 where
192 combine r (k,v) = Map.insertWith (++) k v r
193 collect = liftM (foldl' combine Map.empty) . mapM prep
194 prep (k, as, e@(L t s _)) =
195 do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)
196 return (k,[v])
197 fields fs =
198 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
199 hidden = fields . map (second jsList) .
200 filter (not . null . snd) . Map.toList . Map.map tail
201 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
204instance ToJS Expr where
205 toJS expr =
206 case expr of
207 Var x -> return $ x
208 Chr c -> return $ quoted [c]
209 Str s -> return $ "_str" ++ parens (quoted s)
210 IntNum n -> return $ show n
211 FloatNum n -> return $ show n
212 Boolean b -> return $ if b then "true" else "false"
213 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
214 Access e x -> access x `liftM` toJS' e
215 Remove e x -> remove x `liftM` toJS' e
216 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
217 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
218 setField fs' `liftM` toJS' e
219 Record fs -> makeRecord fs
220 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
222 If eb et ef ->
223 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
225 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
227 App e1 e2 -> jsApp e1 e2
228 Let defs e -> jsLet defs e
229 Data name es ->
230 do fs <- mapM toJS' es
231 return $ case name of
232 "Nil" -> jsNil
233 "Cons" -> jsCons (head fs) ((head . tail) fs)
234 _ -> jsObj $ ("ctor:" ++ show name) : fields
235 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
237 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
238 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
239 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
241jsApp e1 e2 =
242 do f <- toJS' func
243 as <- mapM toJS' args
244 return $ case as of
245 [a] -> f ++ parens a
246 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
247 where
248 (func, args) = go [e2] e1
249 go args e =
250 case e of
251 (L _ _ (App e1 e2)) -> go (e2 : args) e1
252 _ -> (e, args)
254formatMarkdown = concatMap f
255 where f '\'' = "\\'"
256 f '\n' = "\\n"
257 f '"' = "\""
258 f c = [c]
260multiIfToJS span ps =
261 case last ps of
262 (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
263 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
264 where
265 format base ps =
266 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
267 f (b,e) = do b' <- toJS' b
268 e' <- toJS' e
269 return (b' ++ " ? " ++ e')
271jsLet defs e' = do ds <- jsDefs defs
272 e <- toJS' e'
273 return $ jsFunc "" (concat ds ++ ret e) ++ "()"
274 where
275 jsDefs defs = mapM toJS (sortBy f defs)
276 f a b = compare (valueOf a) (valueOf b)
277 valueOf (FnDef _ [] _) = 2
278 valueOf (FnDef _ _ _) = 1
279 valueOf (OpDef _ _ _ _) = 1
280 valueOf (TypeAnnotation _ _) = 0
282caseToJS span e ps = do
283 match <- caseToMatch ps
284 e' <- toJS' e
285 let (match',stmt) = case (match,e) of
286 (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
287 (Match name _ _, _) -> (match, assign name e')
288 _ -> (match, "")
289 matches <- matchToJS span match'
290 return $ "function(){ " ++ stmt ++ 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) {",
298 indent cases, "\n}", finally ]
299 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
300 Break -> return "break;"
301 Other e -> ret `liftM` toJS' e
302 Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
303 where
304 dropEnd acc [] = acc
305 dropEnd acc (m:ms) =
306 case m of
307 Other _ -> acc ++ [m]
308 _ -> 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 [ "\ncase ", quoted name, ":", indent 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 "|>" -> 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 ]