git.iko.soy/elk
on 2f5d445 help sign in
elk/elm/src/Gen/CompileToJS.hs
206 lines 9.2 kB history raw
2module CompileToJS (showErr, jsModule) where
4import Ast
5import Control.Arrow (first)
6import Control.Monad (liftM,(<=<),join,ap)
7import Data.Char (isAlpha,isDigit)
8import Data.List (intercalate,sortBy,inits)
9import Data.Map (toList)
10import Data.Maybe (mapMaybe)
12import Initialize
13import Rename (derename)
14import Cases
15import Guid
17showErr :: String -> String
18showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"
19 where msg = show . concatMap (++"<br>") . lines $ err
21parens s = "(" ++ s ++ ")"
22braces s = "{" ++ s ++ "}"
23jsList ss = "["++ intercalate "," ss ++"]"
24jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
25assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"
26ret e = "\nreturn "++ e ++";"
27iff a b c = a ++ "?" ++ b ++ ":" ++ c
29mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))
30globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
32tryBlock escapees names e =
33 concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"
34 , "ElmCode.main=function() {"
35 , "var msg = ('<br/><h2>Your browser may not be supported. " ++
36 "Are you using a modern browser?</h2>' +" ++
37 " '<br/><span style=\"color:grey\">Runtime Error in " ++
38 intercalate "." names ++ " module:<br/>' + e + '" ++ msg ++ "</span>');"
39 , "document.body.innerHTML = Text.monospace(msg);"
40 , "throw e;"
41 , "};}"
42 ]
43 where msg | escapees /= [] = concat [ "<br/><br/>The problem may stem from an improper usage of:<br/>"
44 , intercalate ", " escapees ]
45 | otherwise = ""
47jsModule (escapees, Module names exports imports stmts) =
48 tryBlock escapees (tail modNames) $ concat
49 [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
50 map (intercalate ".") . drop 2 . inits $
51 take (length modNames - 1) modNames
52 , "\nif (" ++ modName ++ ") throw \"Module name collision, '" ++
53 intercalate "." (tail modNames) ++ "' is already defined.\"; "
54 , globalAssign modName $ jsFunc "" (includes ++body++ export) ++ "()"
55 , mainEquals $ modName ++ ".main" ]
56 where modNames = if null names then ["ElmCode", "Main"]
57 else "ElmCode" : names
58 modName = intercalate "." modNames
59 includes = concatMap jsImport $ map (first ("ElmCode."++)) imports
60 body = stmtsToJS stmts
61 export = getExports exps stmts
62 exps = if null exports then ["main"] else exports
64getExports names stmts = ret . braces $ intercalate "," pairs
65 where pairs = mapMaybe pair $ concatMap get stmts
66 pair x = if y `elem` names then Just $ y ++ ":" ++ x else Nothing
67 where y = derename x
68 get s = case s of Def x _ _ -> [x]
69 Datatype _ _ tcs -> map fst tcs
70 ImportEvent _ _ x _ -> [x]
71 ExportEvent _ _ _ -> []
74jsImport (modul, how) =
75 concat [ "\ntry{" ++ modul ++ " instanceof Object} catch(e) {throw \"Module '"
76 , drop 1 (dropWhile (/='.') modul)
77 , "' is missing. Compile with --make flag or load missing "
78 , "module in a separate JavaScript file.\";}" ] ++
79 jsImport' (modul, how)
81jsImport' (modul, As name) = assign name modul
82jsImport' (modul, Importing []) = jsImport' (modul, Hiding [])
83jsImport' (modul, Importing vs) =
84 concatMap (\v -> assign v $ modul ++ "." ++ v) vs
85jsImport' (modul, Hiding vs) =
86 concat [ "\nfor(var i in " ++ modul ++ "){"
87 , assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs
88 , "\nif (hiddenVars.indexOf(i) >= 0) continue;"
89 , globalAssign "this[i]" $ modul ++ "[i]"
90 , "}" ]
92stmtsToJS :: [Statement] -> String
93stmtsToJS stmts = concatMap stmtToJS (sortBy cmpStmt stmts)
94 where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
95 valueOf s = case s of Datatype _ _ _ -> 1
96 ImportEvent _ _ _ _ -> 3
97 Def _ [] _ -> 3
98 Def _ _ _ -> 4
99 ExportEvent _ _ _ -> 5
101stmtToJS :: Statement -> String
102stmtToJS (Def name [] e) = assign name (toJS e)
103stmtToJS (Def name (a:as) e) = "\nfunction " ++ name ++ parens a ++
104 braces (ret . toJS $ foldr Lambda e as) ++ ";"
105stmtToJS (Datatype _ _ tcs) = concatMap (stmtToJS . toDef) tcs
106 where toDef (name,args) = Def name vars $ Data (derename name) (map Var vars)
107 where vars = map (('a':) . show) [1..length args]
108stmtToJS (ImportEvent js base elm _) =
109 concat [ "\nvar " ++ elm ++ " = Elm.Input(" ++ toJS base ++ ");"
110 , "\nSignal.addListener(document, '" ++ js
111 , "', function(e) { Dispatcher.notify(" ++ elm
112 , ".id, e.value); });" ]
113stmtToJS (ExportEvent js elm _) =
114 concat [ "\nlift(function(v) { var e = document.createEvent('Event');"
115 , "e.initEvent('" ++ js ++ "', true, true);"
116 , "e.value = v;"
117 , "document.dispatchEvent(e); return v; })(" ++ elm ++ ");"
118 ]
121toJS = run . toJS'
123toJS' :: Expr -> GuidCounter String
124toJS' expr =
125 case expr of
126 IntNum n -> return $ show n
127 FloatNum n -> return $ show n
128 Var x -> return $ x
129 Chr c -> return $ show c
130 Str s -> return $ "Value.str" ++ parens (show s)
131 Boolean b -> return $ if b then "true" else "false"
132 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
133 Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS' e
134 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
135 If eb et ef -> parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
136 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
137 App (Var "toText") (Str s) -> return $ "toText" ++ parens (show s)
138 App (Var "link") (Str s) -> return $ "link(" ++ show s ++ ")"
139 App (Var "plainText") (Str s) -> return $ "plainText(" ++ show s ++ ")"
140 App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
141 Let defs e -> jsLet defs e
142 Case e cases -> caseToJS e cases
143 Data name es -> (\ss -> jsList $ show name : ss) `liftM` mapM toJS' es
145jsLet defs e' = do
146 body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
147 return $ jsFunc "" body ++ "()"
149jsDefs defs = concat `liftM` mapM toDef (sortBy f defs)
150 where f a b = compare (valueOf a) (valueOf b)
151 valueOf (Definition _ args _) = min 1 (length args)
152 toDef (Definition x [] e) = assign x `liftM` toJS' e
153 toDef (Definition f (a:as) e) = do
154 out <- toJS' $ foldr Lambda e as
155 return $ "\nfunction " ++ f ++ parens a ++ braces (ret out) ++ ";"
157caseToJS e ps = do
158 match <- caseToMatch ps
159 var <- liftM (\n -> "vv" ++ show n) guid
160 matches <- matchToJS var match
161 e' <- toJS' e
162 return $ concat [ "function(", var, "){"
163 , case match of { Match name _ _ -> assign name var ; _ -> "" }
164 , matches
165 , "}", parens e' ]
167matchToJS v (Match name clauses def) = do
168 cases <- concat `liftM` mapM (clauseToJS name) clauses
169 finally <- matchToJS v def
170 return $ concat [ "\nswitch(", name, "[0]){", cases, "\n}", finally ]
171matchToJS _ Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
172matchToJS _ Break = return "break;"
173matchToJS _ (Other e) = ret `liftM` toJS' e
174matchToJS v (Seq ms) = concat `liftM` mapM (matchToJS v) ms
176clauseToJS var (Clause name vars e) = do
177 s <- matchToJS var e
178 return $ concat [ "\ncase ", show name, ":"
179 , concat $ zipWith toDef vars [ 1 .. length vars ]
180 , s ]
181 where toDef v n = assign v (var ++ "[" ++ show n ++ "]")
183jsNil = "[\"Nil\"]"
184jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
185jsRange e1 e2 = (++"()") . jsFunc "" $
186 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
187 "if(lo<=hi){do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
188 ret "lst"
190binop (o:p) e1 e2
191 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
192 | otherwise = case o:p of
193 ":" -> jsCons e1 e2
194 "++" -> append e1 e2
195 "$" -> e1 ++ parens e2
196 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
197 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
198 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
199 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
200 "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'LT')"
201 ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0] === 'GT')"
202 "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0]; return ord === 'LT' || ord === 'EQ'; }()"
203 ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++ e2 ++ ")[0]; return ord === 'GT' || ord === 'EQ'; }()"
204 _ -> parens (e1 ++ (o:p) ++ e2)
206append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)