git.iko.soy/elk
on 482b7ea help sign in
elk/elm/src/Gen/CompileToJS.hs
145 lines 6.0 kB history raw
2module CompileToJS (showErr, jsModule) where
4import Ast
5import Control.Monad (liftM,(<=<),join)
6import Data.Char (isAlpha,isDigit)
7import Data.List (intercalate,sortBy,inits)
8import Data.Map (toList)
9import Data.Maybe (mapMaybe)
11import Initialize
13showErr :: String -> String
14showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
15 where msg = show . concatMap (++"<br>") . lines $ err
17parens = ("("++) . (++")")
18braces = ("{"++) . (++"}")
19jsList = ("["++) . (++"]") . intercalate ","
20jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
21assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
22ret e = "\nreturn "++ e ++";"
23iff a b c = a ++ "?" ++ b ++ ":" ++ c
25mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))
26globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
28tryBlock names e =
29 concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"
30 , "ElmCode.main=function() {"
31 , "var msg = ('<br><h2>Your browser may not be supported. " ++
32 "Are you using a modern browser?</h2>' +" ++
33 " '<br><span style=\"color:grey\">Runtime Error in " ++
34 intercalate "." names ++ " module:<br>' + e + '</span>');"
35 , "document.body.innerHTML = Text.monospace(msg);"
36 , "throw e;"
37 , "};}"
38 ]
41jsModule (Module names exports imports defs) =
42 tryBlock (tail modNames) $ concat
43 [ concatMap (\n -> globalAssign n $ n ++ " || {}") . map (intercalate ".") . drop 2 . inits $ take (length modNames - 1) modNames
44 , "\nif (" ++ modName ++ ") throw \"Module name collision, '" ++ intercalate "." (tail modNames) ++ "' is already defined.\"; "
45 , globalAssign modName $ jsFunc "" (includes ++ body ++ export) ++ "()"
46 , mainEquals $ modName ++ ".main" ]
47 where modNames = if null names then ["ElmCode", "Main"] else "ElmCode" : names
48 modName = intercalate "." modNames
49 includes = concatMap jsImport $
50 map (\(x,y) -> ("ElmCode." ++ x,y)) imports
51 body = jsDefs defs
52 export = ret . braces . intercalate "," $ mapMaybe getNames defs
53 exps = if null exports then ["main"] else exports
54 getNames (x,_) =
55 let y = reverse . tail . dropWhile isDigit $ reverse x in
56 if y `elem` exps then Just $ y ++ ":" ++ x else Nothing
58jsImport (modul, how) =
59 concat [ "\ntry{" ++ modul ++ "} catch(e) {throw \"Module '"
60 , drop 1 (dropWhile (/='.') modul)
61 , "' is missing. Compile with --make flag or load missing "
62 , "module in a separate JavaScript file.\";}" ] ++ jsImport' (modul, how)
64jsImport' (modul, As name) = assign name modul
65jsImport' (modul, Importing []) = jsImport' (modul, Hiding [])
66jsImport' (modul, Importing vs) =
67 concatMap (\v -> assign v $ modul ++ "." ++ v) vs
68jsImport' (modul, Hiding vs) =
69 concat [ "\nfor(var i in " ++ modul ++ "){"
70 , assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs
71 , "\nif (hiddenVars.indexOf(i) >= 0) continue;"
72 , globalAssign "this[i]" $ modul ++ "[i]"
73 , "}" ]
76toJS expr =
77 case expr of
78 Number n -> show n
79 Var x -> x
80 Chr c -> show c
81 Str s -> toJS . list $ map Chr s
82 Boolean b -> if b then "true" else "false"
83 Range lo hi -> jsRange (toJS lo) (toJS hi)
84 Access e lbl -> toJS e ++ "." ++ lbl
85 Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
86 If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
87 Lambda v e -> jsFunc v $ ret (toJS e)
88 App (Var "toText") (Str s) -> show s
89 App (Var "link") (Str s) -> "link(" ++ show s ++ ")"
90 App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"
91 App e1 e2 -> toJS e1 ++ parens (toJS e2)
92 Let defs e -> jsLet defs e
93 Case e cases -> jsCase e cases
94 Data name es -> jsList $ show name : map toJS es
96jsLet defs e' = jsFunc "" (jsDefs defs ++ ret (toJS e')) ++ "()"
98jsDefs defs = concatMap toDef $ sortBy f defs
99 where f a b = compare (isLambda a) (isLambda b)
100 isLambda (_, Lambda _ _) = 1
101 isLambda _ = 0
102 toDef (f, Lambda x e) =
103 "\nfunction " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
104 toDef (x, e) = assign x (toJS e)
106jsCase e [c] = jsMatch c ++ parens (toJS e)
107jsCase e cases = "(function(){" ++
108 assign "v" (toJS e) ++
109 assign "c" jsCases ++
110 "for(var i=c.length;i--;){" ++
111 assign "r" "c[i](v)" ++
112 "if(r!==undefined){return r;}}}())"
113 where jsCases = jsList $ map jsMatch (reverse cases)
115jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
116match p v hole =
117 case p of
118 PAnything -> hole
119 PVar x -> assign x v ++ hole
120 PData name ps ->
121 "if(" ++ show name ++ "!==" ++ v ++
122 "[0]){return undefined;}else{"++body++"}"
123 where matches = zipWith match ps vs
124 vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
125 body = foldr ($) hole matches
127jsNil = "[\"Nil\"]"
128jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
129jsRange e1 e2 = (++"()") . jsFunc "" $
130 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
131 "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++
132 ret "lst"
134binop (o:p) e1 e2
135 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
136 | otherwise = case o:p of
137 ":" -> jsCons e1 e2
138 "++" -> append e1 e2
139 "$" -> e1 ++ parens e2
140 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
141 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
142 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
143 _ -> e1 ++ (o:p) ++ e2
145append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)