git.iko.soy/elk
on 1dbbc59 help sign in
elk/compiler/Gen/CompileToJS.hs
339 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 LetBoundVars
17import Parse.Library (isOp)
18import Rename (deprime)
19import Types.Types ( Type(RecordT) )
21showErr :: String -> String
22showErr err = "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
23 where msg = show . concatMap (++"<br>") . lines $ err
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 ++ "\nvar " ++ intercalate ", " (map def vs) ++ ";"
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 where
106 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
107 setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
108 where
109 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
110 subnames = map (intercalate ".") . tail . inits . init . split
111 split names = case go [] names of
112 (name, []) -> [name]
113 (name, ns) -> name : split ns
114 go name str = case str of
115 '.':rest -> (reverse name, rest)
116 c:rest -> go (c:name) rest
117 [] -> (reverse name, [])
121stmtsToJS :: [Statement] -> String
122stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
123 return (vars ++ concat program)
124 where
125 vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
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 func body = jsFunc (intercalate ", " as) (ret body)
144 wrapper e | length as == 1 = e
145 | otherwise = 'F' : show (length as) ++ parens e
146 toJS (OpDef op a1 a2 e) =
147 do body <- toJS' e
148 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
149 return (globalAssign ("$op['" ++ op ++ "']") func)
151instance ToJS Statement where
152 toJS stmt =
153 case stmt of
154 Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
155 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
156 where toDef (name,args) =
157 let vars = map (('a':) . show) [1..length args] in
158 Definition . FnDef name vars . noContext $
159 Data (derename name) (map (noContext . Var) vars)
160 ImportEvent js base elm _ ->
161 do v <- toJS' base
162 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
163 , "\ndocument.addEventListener('", js
164 , "_' + elm.id, function(e) { elm.notify(", elm
165 , ".id, e.value); });" ]
166 ExportEvent js elm _ ->
167 return $ concat [ "\nlift(function(v) { "
168 , "var e = document.createEvent('Event');"
169 , "e.initEvent('", js, "_' + elm.id, true, true);"
170 , "e.value = v;"
171 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
172 TypeAnnotation _ _ -> return ""
173 TypeAlias n _ t -> return ""
175toJS' :: CExpr -> GuidCounter String
176toJS' (C txt span expr) =
177 case expr of
178 MultiIf ps -> multiIfToJS span ps
179 Case e cases -> caseToJS span e cases
180 _ -> toJS expr
182remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
183addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
184setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
185 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
186access x e = parens e ++ "." ++ x
187makeRecord kvs = record `liftM` collect kvs
188 where
189 combine r (k,v) = Map.insertWith (++) k v r
190 collect = liftM (foldl' combine Map.empty) . mapM prep
191 prep (k, as, e@(C t s _)) =
192 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
193 return (k,[v])
194 fields fs =
195 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
196 hidden = fields . map (second jsList) .
197 filter (not . null . snd) . Map.toList . Map.map tail
198 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
201instance ToJS Expr where
202 toJS expr =
203 case expr of
204 IntNum n -> return $ show n
205 FloatNum n -> return $ show n
206 Var x -> return $ x
207 Chr c -> return $ quoted [c]
208 Str s -> return $ "_str" ++ parens (quoted s)
209 Boolean b -> return $ if b then "true" else "false"
210 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
211 Access e x -> access x `liftM` toJS' e
212 Remove e x -> remove x `liftM` toJS' e
213 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
214 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
215 setField fs' `liftM` toJS' e
216 Record fs -> makeRecord fs
217 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
219 If eb et ef ->
220 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
222 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
224 App e1 e2 -> jsApp e1 e2
225 Let defs e -> jsLet defs e
226 Data name es ->
227 do fs <- mapM toJS' es
228 return $ case name of
229 "Nil" -> jsNil
230 "Cons" -> jsCons (head fs) ((head . tail) fs)
231 _ -> jsObj $ ("ctor:" ++ show name) : fields
232 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
234 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
235 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
236 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
238jsApp e1 e2 =
239 do f <- toJS' func
240 as <- mapM toJS' args
241 return $ case as of
242 [a] -> f ++ parens a
243 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
244 where
245 (func, args) = go [e2] e1
246 go args e =
247 case e of
248 (C _ _ (App e1 e2)) -> go (e2 : args) e1
249 _ -> (e, args)
251formatMarkdown = concatMap f
252 where f '\'' = "\\'"
253 f '\n' = "\\n"
254 f '"' = "\""
255 f c = [c]
257multiIfToJS span ps =
258 case last ps of
259 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
260 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
261 where
262 format base ps =
263 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
264 f (b,e) = do b' <- toJS' b
265 e' <- toJS' e
266 return (b' ++ " ? " ++ e')
268jsLet defs e' = do ds <- jsDefs defs
269 e <- toJS' e'
270 return $ parens (intercalate ", " ds ++ ", " ++ e)
271 where
272 jsDefs defs = mapM toJS (sortBy f defs)
273 f a b = compare (valueOf a) (valueOf b)
274 valueOf (FnDef _ args _) = min 1 (length args)
275 valueOf (OpDef _ _ _ _) = 1
277caseToJS span e ps = do
278 match <- caseToMatch ps
279 e' <- toJS' e
280 (match',stmt) <- case (match,e) of
281 (Match name _ _, C _ _ (Var x)) ->
282 return (matchSubst [(name,x)] match, Nothing)
283 (Match name _ _, _) ->
284 return (match, Just (name ++ " = " ++ e'))
285 _ -> return (match, Nothing)
286 matches <- matchToJS span match'
287 return $ case stmt of
288 Nothing -> matches
289 Just exp -> parens (exp ++ ", " ++ matches)
291matchToJS span match =
292 let sqnc e1 e2 = parens ("e=" ++ e1 ++ ":null,e!==null?e:" ++ e2)
293 in case match of
294 Match name clauses def ->
295 do cases <- intercalate ":" `liftM` mapM (clauseToJS span name) clauses
296 finally <- matchToJS span def
297 return (sqnc cases finally)
298 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
299 Break -> return "null"
300 Other e -> toJS' e
301 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
302 where dropEnd acc [] = acc
303 dropEnd acc (m:ms) =
304 case m of
305 Other _ -> acc ++ [m]
306 _ -> 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 [ var, ".ctor===", quoted name, "?", 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.compare(" ++ 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 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
328 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
329 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
330 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
331 "<" -> jsCompare e1 e2 "==='LT'"
332 ">" -> jsCompare e1 e2 "==='GT'"
333 "<=" -> jsCompare e1 e2 "!=='GT'"
334 ">=" -> jsCompare e1 e2 "!=='LT'"
335 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
336 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
337 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
338 | otherwise -> concat [ "$op['", o:p, "']"
339 , parens e1, parens e2 ]