git.iko.soy/elk
on 710484e help sign in
elk/elm/src/Gen/CompileToJS.hs
96 lines 3.6 kB history raw
2module CompileToJS (compile, compileToJS) where
4import Ast
5import Control.Monad (liftM,(<=<),join)
6import Data.Char (isAlpha)
7import Data.List (intercalate,sortBy)
8import Data.Map (toList)
10import Initialize
12showErr :: String -> String
13showErr err = "text(monospace(" ++ msg ++ "))"
14 where msg = show . concatMap (++"<br>") . lines $ err
16compile = (return . addMain . toJS) <=< initialize
17compileToJS = addMain . either showErr toJS
18addMain body = "function main(){return " ++ body ++ ";}"
20parens = ("("++) . (++")")
21braces = ("{"++) . (++"}")
22jsList = ("["++) . (++"]") . intercalate ","
23jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
24assign x e = "var " ++ x ++ "=" ++ e ++ ";"
25ret e = "return "++ e ++";"
26iff a b c = a ++ "?" ++ b ++ ":" ++ c
28toJS expr =
29 case expr of
30 Number n -> show n
31 Var x -> x
32 Chr c -> show c
33 Str s -> toJS . list $ map Chr s
34 Boolean b -> if b then "true" else "false"
35 Range lo hi -> jsRange (toJS lo) (toJS hi)
36 Access e lbl -> toJS e ++ "." ++ lbl
37 Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
38 If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
39 Lambda v e -> jsFunc v $ ret (toJS e)
40 App (Var "toText") (Str s) -> show s
41 App (Var "link") (Str s) -> "link(" ++ show s ++ ")"
42 App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"
43 App e1 e2 -> toJS e1 ++ parens (toJS e2)
44 Let defs e -> jsLet defs e
45 Case e cases -> jsCase e cases
46 Data name es -> jsList $ show name : map toJS es
48jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()"
49 where defs' = concatMap toDef $ sortBy f defs
50 f a b = compare (isLambda a) (isLambda b)
51 isLambda (_, Lambda _ _) = 1
52 isLambda _ = 0
53 toDef (f, Lambda x e) =
54 "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
55 toDef (x, e) = assign x (toJS e)
57jsCase e [c] = jsMatch c ++ parens (toJS e)
58jsCase e cases = "(function(){" ++
59 assign "v" (toJS e) ++
60 assign "c" jsCases ++
61 "for(var i=c.length;i--;){" ++
62 assign "r" "c[i](v)" ++
63 "if(r!==undefined){return r;}}}())"
64 where jsCases = jsList $ map jsMatch (reverse cases)
66jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
67match p v hole =
68 case p of
69 PAnything -> hole
70 PVar x -> assign x v ++ hole
71 PData name ps ->
72 "if(" ++ show name ++ "!==" ++ v ++
73 "[0]){return undefined;}else{"++body++"}"
74 where matches = zipWith match ps vs
75 vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
76 body = foldr ($) hole matches
78jsNil = "[\"Nil\"]"
79jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
80jsRange e1 e2 = (++"()") . jsFunc "" $
81 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
82 "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++
83 ret "lst"
85binop (o:p) e1 e2
86 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
87 | otherwise = case o:p of
88 ":" -> jsCons e1 e2
89 "++" -> append e1 e2
90 "$" -> e1 ++ parens e2
91 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
92 "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
93 "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
94 _ -> e1 ++ (o:p) ++ e2
96append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)