git.iko.soy/elk
on 1af2ff9 help sign in
elk/compiler/Gen/CompileToJS.hs
338 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 Rename (deprime)
18import Types.Types ( Type(RecordT) )
20showErr :: String -> String
21showErr err = "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
22 where msg = show . concatMap (++"<br>") . lines $ err
24indent = concatMap f
25 where f '\n' = "\n "
26 f c = [c]
28internalImports =
29 [ ("N" , "Elm.Native"),
30 ("_N", "N.Utils(elm)"),
31 ("_L", "N.List(elm)"),
32 ("_E", "N.Error(elm)"),
33 ("_str", "N.JavaScript(elm).toString")
34 ]
36parens s = "(" ++ s ++ ")"
37brackets s = "{" ++ s ++ "}"
38jsObj = brackets . intercalate ", "
39jsList ss = "["++ intercalate "," ss ++"]"
40jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
41assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
42ret e = "\nreturn "++ e ++";"
43iff a b c = a ++ "?" ++ b ++ ":" ++ c
44quoted s = "'" ++ concatMap f s ++ "'"
45 where f '\n' = "\\n"
46 f '\'' = "\\'"
47 f '\t' = "\\t"
48 f '\"' = "\\\""
49 f '\\' = "\\\\"
50 f c = [c]
52globalAssign n e = "\n" ++ assign' n e ++ ";"
53assign' n e = n ++ " = " ++ e
55jsModule (Module names exports imports stmts) =
56 setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
57 where
58 modNames = if null names then ["Main"] else names
59 modName = intercalate "." modNames
60 includes = concatMap jsImport imports
61 body = stmtsToJS stmts
62 defs = assign "$op" "{}"
63 program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
64 setup ("elm":"Native":modNames) ++
65 assign "_" ("elm.Native." ++ modName ++ "||{}") ++
66 getExports exports stmts ++ setup ("elm":modNames) ++
67 ret (assign' ("elm." ++ modName) "_") ++ "\n"
68 setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
69 map (intercalate ".") . drop 2 . inits $ init modNames
70 usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
72getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
73 where exNames n = either derename id n `elem` names
74 exports | null names = concatMap get stmts
75 | otherwise = filter exNames (concatMap get stmts)
77 (fns,ops) = partitionEithers exports
79 opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
80 fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
82 op = ("_.$op = "++) . jsObj $ map opPair ops
84 get' (FnDef x _ _) = Left x
85 get' (OpDef op _ _ _) = Right op
86 get s = case s of Definition d -> [ get' d ]
87 Datatype _ _ tcs -> map (Left . fst) tcs
88 ImportEvent _ _ x _ -> [ Left x ]
89 ExportEvent _ _ _ -> []
90 TypeAlias _ _ _ -> []
91 TypeAnnotation _ _ -> []
94jsImport (modul, how) =
95 case how of
96 As name -> assign name ("Elm." ++ modul ++ parens "elm")
97 Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
98 "; for(var k in _){if(k in hiding)continue;" ++
99 "eval('var '+k+'=_[\"'+k+'\"]')}"
100 Importing vs -> include ++ "\nvar " ++ intercalate ", " (map def vs) ++ ";"
101 where
102 imprt v = assign' v ("_." ++ v)
103 def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
104 where
105 include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
106 setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
107 where
108 defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
109 subnames = map (intercalate ".") . tail . inits . init . split
110 split names = case go [] names of
111 (name, []) -> [name]
112 (name, ns) -> name : split ns
113 go name str = case str of
114 '.':rest -> (reverse name, rest)
115 c:rest -> go (c:name) rest
116 [] -> (reverse name, [])
120stmtsToJS :: [Statement] -> String
121stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
122 return (vars ++ concat program)
123 where
124 vars = "\nvar " ++ intercalate ", " ("e":"case0":letBoundVars stmts) ++ ";"
125 cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
126 valueOf s = case s of
127 Datatype _ _ _ -> 1
128 ImportEvent _ _ _ _ -> 2
129 Definition (FnDef f [] _) ->
130 if derename f == "main" then 5 else 4
131 Definition _ -> 3
132 ExportEvent _ _ _ -> 6
133 TypeAlias _ _ _ -> 0
134 TypeAnnotation _ _ -> 0
136class ToJS a where
137 toJS :: a -> GuidCounter String
139instance ToJS Def where
140 toJS (FnDef x [] e) = assign' x `liftM` toJS' e
141 toJS (FnDef f as e) = (assign' f . wrapper . func) `liftM` toJS' e
142 where func body = jsFunc (intercalate ", " as) (ret body)
143 wrapper e | length as == 1 = e
144 | otherwise = 'F' : show (length as) ++ parens e
145 toJS (OpDef op a1 a2 e) =
146 do body <- toJS' e
147 let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
148 return (globalAssign ("$op['" ++ op ++ "']") func)
150instance ToJS Statement where
151 toJS stmt =
152 case stmt of
153 Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
154 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
155 where toDef (name,args) =
156 let vars = map (('a':) . show) [1..length args] in
157 Definition . FnDef name vars . noContext $
158 Data (derename name) (map (noContext . Var) vars)
159 ImportEvent js base elm _ ->
160 do v <- toJS' base
161 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
162 , "\ndocument.addEventListener('", js
163 , "_' + elm.id, function(e) { elm.notify(", elm
164 , ".id, e.value); });" ]
165 ExportEvent js elm _ ->
166 return $ concat [ "\nlift(function(v) { "
167 , "var e = document.createEvent('Event');"
168 , "e.initEvent('", js, "_' + elm.id, true, true);"
169 , "e.value = v;"
170 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
171 TypeAnnotation _ _ -> return ""
172 TypeAlias n _ t -> return ""
174toJS' :: CExpr -> GuidCounter String
175toJS' (C txt span expr) =
176 case expr of
177 MultiIf ps -> multiIfToJS span ps
178 Case e cases -> caseToJS span e cases
179 _ -> toJS expr
181remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
182addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
183setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
184 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
185access x e = parens e ++ "." ++ x
186makeRecord kvs = record `liftM` collect kvs
187 where
188 combine r (k,v) = Map.insertWith (++) k v r
189 collect = liftM (foldl' combine Map.empty) . mapM prep
190 prep (k, as, e@(C t s _)) =
191 do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
192 return (k,[v])
193 fields fs =
194 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
195 hidden = fields . map (second jsList) .
196 filter (not . null . snd) . Map.toList . Map.map tail
197 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
200instance ToJS Expr where
201 toJS expr =
202 case expr of
203 IntNum n -> return $ show n
204 FloatNum n -> return $ show n
205 Var x -> return $ x
206 Chr c -> return $ quoted [c]
207 Str s -> return $ "_str" ++ parens (quoted s)
208 Boolean b -> return $ if b then "true" else "false"
209 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
210 Access e x -> access x `liftM` toJS' e
211 Remove e x -> remove x `liftM` toJS' e
212 Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
213 Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
214 setField fs' `liftM` toJS' e
215 Record fs -> makeRecord fs
216 Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
218 If eb et ef ->
219 parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
221 Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
223 App e1 e2 -> jsApp e1 e2
224 Let defs e -> jsLet defs e
225 Data name es ->
226 do fs <- mapM toJS' es
227 return $ case name of
228 "Nil" -> jsNil
229 "Cons" -> jsCons (head fs) ((head . tail) fs)
230 _ -> jsObj $ ("ctor:" ++ show name) : fields
231 where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
233 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
234 where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
235 md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
237jsApp e1 e2 =
238 do f <- toJS' func
239 as <- mapM toJS' args
240 return $ case as of
241 [a] -> f ++ parens a
242 _ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
243 where
244 (func, args) = go [e2] e1
245 go args e =
246 case e of
247 (C _ _ (App e1 e2)) -> go (e2 : args) e1
248 _ -> (e, args)
250formatMarkdown = concatMap f
251 where f '\'' = "\\'"
252 f '\n' = "\\n"
253 f '"' = "\""
254 f c = [c]
256multiIfToJS span ps =
257 case last ps of
258 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
259 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
260 where
261 format base ps =
262 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
263 f (b,e) = do b' <- toJS' b
264 e' <- toJS' e
265 return (b' ++ " ? " ++ e')
267jsLet defs e' = do ds <- jsDefs defs
268 e <- toJS' e'
269 return $ parens (intercalate ", " ds ++ ", " ++ e)
270 where
271 jsDefs defs = mapM toJS (sortBy f defs)
272 f a b = compare (valueOf a) (valueOf b)
273 valueOf (FnDef _ args _) = min 1 (length args)
274 valueOf (OpDef _ _ _ _) = 1
276caseToJS span e ps = do
277 match <- caseToMatch ps
278 e' <- toJS' e
279 (match',stmt) <- case (match,e) of
280 (Match name _ _, C _ _ (Var x)) ->
281 return (matchSubst [(name,x)] match, Nothing)
282 (Match name _ _, _) ->
283 return (match, Just (name ++ " = " ++ e'))
284 _ -> return (match, Nothing)
285 matches <- matchToJS span match'
286 return $ case stmt of
287 Nothing -> matches
288 Just exp -> parens (exp ++ ", " ++ matches)
290matchToJS span match =
291 let sqnc e1 e2 = parens ("e=" ++ e1 ++ ":null,e!==null?e:" ++ e2)
292 in case match of
293 Match name clauses def ->
294 do cases <- intercalate ":" `liftM` mapM (clauseToJS span name) clauses
295 finally <- matchToJS span def
296 return (sqnc cases finally)
297 Fail -> return ("_E.Case" ++ parens (quoted (show span)))
298 Break -> return "null"
299 Other e -> toJS' e
300 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
301 where dropEnd acc [] = acc
302 dropEnd acc (m:ms) =
303 case m of
304 Other _ -> acc ++ [m]
305 _ -> dropEnd (acc ++ [m]) ms
308clauseToJS span var (Clause name vars e) = do
309 let vars' = map (\n -> var ++ "._" ++ show n) [0..]
310 s <- matchToJS span $ matchSubst (zip vars vars') e
311 return $ concat [ var, ".ctor===", quoted name, "?", s ]
313jsNil = "_L.Nil"
314jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
315jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
316jsCompare e1 e2 op = parens ("_N.compare(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
318binop (o:p) e1 e2
319 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
320 | otherwise =
321 let ops = ["+","-","*","/","&&","||"] in
322 case o:p of
323 "::" -> jsCons e1 e2
324 "++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
325 "$" -> e1 ++ parens e2
326 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
327 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
328 "==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
329 "/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
330 "<" -> jsCompare e1 e2 "==='LT'"
331 ">" -> jsCompare e1 e2 "==='GT'"
332 "<=" -> jsCompare e1 e2 "!=='GT'"
333 ">=" -> jsCompare e1 e2 "!=='LT'"
334 "<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
335 "~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
336 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
337 | otherwise -> concat [ "$op['", o:p, "']"
338 , parens e1, parens e2 ]