git.iko.soy/elk
on 0ca86e4 help sign in
elk/src/CompileToJS.hs
88 lines 3.2 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 Boolean b -> if b then "true" else "false"
31 Range lo hi -> jsRange (toJS lo) (toJS hi)
32 Access e lbl -> toJS e ++ "." ++ lbl
33 Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
34 If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
35 Lambda v e -> jsFunc v $ ret (toJS e)
36 App e1 e2 -> toJS e1 ++ parens (toJS e2)
37 Let defs e -> jsLet defs e
38 Case e cases -> jsCase e cases
39 Data name es -> jsList $ show name : map toJS es
41jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()"
42 where defs' = concatMap toDef $ sortBy f defs
43 f a b = compare (isLambda a) (isLambda b)
44 isLambda (_, Lambda _ _) = 1
45 isLambda _ = 0
46 toDef (f, Lambda x e) =
47 "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
48 toDef (x, e) = assign x (toJS e)
50jsCase e [c] = jsMatch c ++ parens (toJS e)
51jsCase e cases = "(function(){" ++
52 assign "v" (toJS e) ++
53 assign "c" jsCases ++
54 "for(var i=c.length;i--;){" ++
55 assign "r" "c[i](v)" ++
56 "if(r!==undefined){return r;}}}())"
57 where jsCases = jsList $ map jsMatch (reverse cases)
59jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
60match p v hole =
61 case p of
62 PAnything -> hole
63 PVar x -> assign x v ++ hole
64 PData name ps ->
65 "if(" ++ show name ++ "!==" ++ v ++
66 "[0]){return undefined;}else{"++body++"}"
67 where matches = zipWith match ps vs
68 vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
69 body = foldr ($) hole matches
71jsNil = "[\"Nil\"]"
72jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
73jsRange e1 e2 = (++"()") . jsFunc "" $
74 assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
75 "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++
76 ret "lst"
78binop (o:p) e1 e2
79 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
80 | otherwise = case o:p of
81 ":" -> jsCons e1 e2
82 "++" -> append e1 e2
83 "$" -> e1 ++ parens e2
84 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
85 "/=" -> e1 ++ "!==" ++ e2
86 _ -> e1 ++ (o:p) ++ e2
88append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)