git.iko.soy/elk
on 970277f help sign in
elk/compiler/Gen/CompileToJS.hs
343 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 ++ 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 (vars ++ concat program)
126 where
127 vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
128 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
129 valueOf s = case s of
130 Datatype _ _ _ -> 1
131 ImportEvent _ _ _ _ -> 2
132 Definition (FnDef f [] _) ->
133 if derename f == "main" then 5 else 4
134 Definition _ -> 3
135 ExportEvent _ _ _ -> 6
136 TypeAlias _ _ _ -> 0
137 TypeAnnotation _ _ -> 0
139class ToJS a where
140 toJS :: a -> GuidCounter String
142instance ToJS Def where
143 toJS (FnDef x [] e) = assign' x `liftM` toJS' e
144 toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
145 where 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)
153instance ToJS Statement where
154 toJS stmt =
155 case stmt of
156 Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
157 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
158 where toDef (name,args) =
159 let vars = map (('a':) . show) [1..length args] in
160 Definition . FnDef name vars . noContext $
161 Data (derename name) (map (noContext . Var) vars)
162 ImportEvent js base elm _ ->
163 do v <- toJS' base
164 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
165 , "\ndocument.addEventListener('", js
166 , "_' + elm.id, function(e) { elm.notify(", elm
167 , ".id, e.value); });" ]
168 ExportEvent js elm _ ->
169 return $ concat [ "\nlift(function(v) { "
170 , "var e = document.createEvent('Event');"
171 , "e.initEvent('", js, "_' + elm.id, true, true);"
172 , "e.value = v;"
173 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
174 TypeAnnotation _ _ -> return ""
175 TypeAlias n _ t -> return ""
177toJS' :: CExpr -> GuidCounter String
178toJS' (C 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@(C t s _)) =
194 do v <- toJS' (foldr (\x e -> C 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 If eb et ef ->
222 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
224 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
226 App e1 e2 -> jsApp e1 e2
227 Let defs e -> jsLet defs e
228 Data name es ->
229 do fs <- mapM toJS' es
230 return $ case name of
231 "Nil" -> jsNil
232 "Cons" -> jsCons (head fs) ((head . tail) fs)
233 _ -> jsObj $ ("ctor:" ++ show name) : fields
234 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
236 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
237 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
238 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
240jsApp e1 e2 =
241 do f <- toJS' func
242 as <- mapM toJS' args
243 return $ case as of
244 [a] -> f ++ parens a
245 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
246 where
247 (func, args) = go [e2] e1
248 go args e =
249 case e of
250 (C _ _ (App e1 e2)) -> go (e2 : args) e1
251 _ -> (e, args)
253formatMarkdown = concatMap f
254 where f '\'' = "\\'"
255 f '\n' = "\\n"
256 f '"' = "\""
257 f c = [c]
259multiIfToJS span ps =
260 case last ps of
261 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
262 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
263 where
264 format base ps =
265 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
266 f (b,e) = do b' <- toJS' b
267 e' <- toJS' e
268 return (b' ++ " ? " ++ e')
270jsLet defs e' = do ds <- jsDefs defs
271 e <- toJS' e'
272 return $ parens (intercalate ", " ds ++ ", " ++ e)
273 where
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 (match',stmt) <- case (match,e) of
283 (Match name _ _, C _ _ (Var x)) ->
284 return (matchSubst [(name,x)] match, Nothing)
285 (Match name _ _, _) ->
286 return (match, Just (name ++ " = " ++ e'))
287 _ -> return (match, Nothing)
288 matches <- matchToJS span match'
289 return $ case stmt of
290 Nothing -> matches
291 Just exp -> parens (exp ++ ", " ++ matches)
293matchToJS span match =
294 let sqnc e1 e2 = parens ("e=" ++ e1 ++ ":null,e!==null?e:" ++ e2)
295 in case match of
296 Match name clauses def ->
297 do cases <- intercalate ":" `liftM` mapM (clauseToJS span name) clauses
298 finally <- matchToJS span def
299 return (sqnc cases finally)
300 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
301 Break -> return "null"
302 Other e -> toJS' e
303 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
304 where dropEnd acc [] = acc
305 dropEnd acc (m:ms) =
306 case m of
307 Other _ -> acc ++ [m]
308 _ -> dropEnd (acc ++ [m]) ms
311clauseToJS span var (Clause name vars e) = do
312 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
313 s <- matchToJS span $ matchSubst (zip vars vars') e
314 return $ concat [ var, ".ctor===", quoted name, "?", s ]
316jsNil = "_L.Nil"
317jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
318jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
319jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
321binop (o:p) e1 e2
322 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
323 | otherwise =
324 let ops = ["+","-","*","/","&&","||"] in
325 case o:p of
326 "::" -> jsCons e1 e2
327 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
328 "$" -> e1 ++ parens e2
329 "<|" -> e1 ++ parens e2
330 "|>" -> e2 ++ parens e1
331 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
332 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
333 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
334 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
335 "<" -> jsCompare e1 e2 "==='LT'"
336 ">" -> jsCompare e1 e2 "==='GT'"
337 "<=" -> jsCompare e1 e2 "!=='GT'"
338 ">=" -> jsCompare e1 e2 "!=='LT'"
339 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
340 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
341 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
342 | otherwise -> concat [ "$op['", o:p, "']"
343 , parens e1, parens e2 ]