git.iko.soy/elk
on e33d329 help sign in
elk/src/CompileToJS.hs
92 lines 3.4 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
13compile = (return . addMain . toJS) <=< initialize
14compileToJS = addMain . either (\err -> "text('"++err++"')") toJS . initialize
15addMain body = "function main(){return " ++ body ++ ";}"
17parens = ("("++) . (++")")
18braces = ("{"++) . (++"}")
19jsList = ("["++) . (++"]") . intercalate ","
20jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
21assign x e = "var " ++ x ++ "=" ++ e ++ ";"
22ret e = "return "++ e ++";"
23iff a b c = a ++ "?" ++ b ++ ":" ++ c
25toJS expr =
26 case expr of
27 Number n -> show n
28 Var x -> x
29 Chr c -> show c
30 Str s -> toJS . list $ map Chr s
31 Boolean b -> if b then "true" else "false"
32 Range lo hi -> jsRange (toJS lo) (toJS hi)
33 Access e lbl -> toJS e ++ "." ++ lbl
34 Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
35 If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
36 Lambda v e -> jsFunc v $ ret (toJS e)
37 App (Var "toText") (Str s) -> show s
38 App (Var "link") (Str s) -> "link(" ++ show s ++ ")"
39 App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"
40 App e1 e2 -> toJS e1 ++ parens (toJS e2)
41 Let defs e -> jsLet defs e
42 Case e cases -> jsCase e cases
43 Data name es -> jsList $ show name : map toJS es
45jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()"
46 where defs' = concatMap toDef $ sortBy f defs
47 f a b = compare (isLambda a) (isLambda b)
48 isLambda (_, Lambda _ _) = 1
49 isLambda _ = 0
50 toDef (f, Lambda x e) =
51 "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
52 toDef (x, e) = assign x (toJS e)
54jsCase e [c] = jsMatch c ++ parens (toJS e)
55jsCase e cases = "(function(){" ++
56 assign "v" (toJS e) ++
57 assign "c" jsCases ++
58 "for(var i=c.length;i--;){" ++
59 assign "r" "c[i](v)" ++
60 "if(r!==undefined){return r;}}}())"
61 where jsCases = jsList $ map jsMatch (reverse cases)
63jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
64match p v hole =
65 case p of
66 PAnything -> hole
67 PVar x -> assign x v ++ hole
68 PData name ps ->
69 "if(" ++ show name ++ "!==" ++ v ++
70 "[0]){return undefined;}else{"++body++"}"
71 where matches = zipWith match ps vs
72 vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
73 body = foldr ($) hole matches
75jsNil = "[\"Nil\"]"
76jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
77jsRange e1 e2 = (++"()") . jsFunc "" $
78 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
79 "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++
80 ret "lst"
82binop (o:p) e1 e2
83 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
84 | otherwise = case o:p of
85 ":" -> jsCons e1 e2
86 "++" -> append e1 e2
87 "$" -> e1 ++ parens e2
88 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
89 "/=" -> e1 ++ "!==" ++ e2
90 _ -> e1 ++ (o:p) ++ e2
92append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)