@@ -0,0 +1,266 @@
1+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
2+
3+module IRTS.JavaScript.JsAST
4+ ( JsExpr(..)
5+ , JsStmt(..)
6+ , jsAst2Text
7+ , jsStmt2Text
8+ , jsLazy
9+ , jsCurryLam
10+ , jsCurryApp
11+ , jsAppN
12+ , js_aux_defs
13+ , jsExpr2Stmt
14+ , jsStmt2Expr
15+ ) where
16+
17+import Data.Data
18+import Data.Text (Text)
19+import qualified Data.Text as T
20+
21+data JsStmt
22+ = JsEmpty
23+ | JsExprStmt JsExpr
24+ | JsFun Text
25+ [Text]
26+ JsStmt
27+ | JsSeq JsStmt
28+ JsStmt
29+ | JsReturn JsExpr
30+ | JsDecVar Text
31+ JsExpr
32+ | JsDecConst Text
33+ JsExpr
34+ | JsDecLet Text
35+ JsExpr
36+ | JsSet JsExpr
37+ JsExpr
38+ | JsIf JsExpr
39+ JsStmt
40+ (Maybe JsStmt)
41+ | JsSwitchCase JsExpr
42+ [(JsExpr, JsStmt)]
43+ (Maybe JsStmt)
44+ | JsError JsExpr
45+ | JsForever JsStmt
46+ | JsContinue
47+ | JsBreak
48+ deriving (Show, Eq, Data, Typeable)
49+
50+data JsExpr
51+ = JsNull
52+ | JsUndefined
53+ | JsThis
54+ | JsLambda [Text]
55+ JsStmt
56+ | JsApp JsExpr
57+ [JsExpr]
58+ | JsPart JsExpr
59+ Text
60+ | JsMethod JsExpr
61+ Text
62+ [JsExpr]
63+ | JsVar Text
64+ | JsArrayProj JsExpr
65+ JsExpr
66+ | JsObj [(Text, JsExpr)]
67+ | JsProp JsExpr
68+ Text
69+ | JsInt Int
70+ | JsBool Bool
71+ | JsInteger Integer
72+ | JsDouble Double
73+ | JsStr Text
74+ | JsArray [JsExpr]
75+ | JsErrorExp JsExpr
76+ | JsUniOp Text
77+ JsExpr
78+ | JsBinOp Text
79+ JsExpr
80+ JsExpr
81+ | JsForeign Text
82+ [JsExpr]
83+ | JsB2I JsExpr
84+ | JsComment Text
85+ | JsForce JsExpr
86+ deriving (Show, Eq, Data, Typeable)
87+
88+indent :: Text -> Text
89+indent x =
90+ let l = T.lines x
91+ il = map (\y -> T.replicate 4 " " `T.append` y) l
92+ in T.unlines il
93+
94+jsCurryLam :: [Text] -> JsExpr -> JsExpr
95+jsCurryLam [] body = body
96+jsCurryLam (x:xs) body = JsLambda [x] $ JsReturn $ jsCurryLam xs body
97+
98+jsCurryApp :: JsExpr -> [JsExpr] -> JsExpr
99+jsCurryApp fn [] = fn
100+jsCurryApp fn args = foldl (\ff aa -> JsApp ff [aa]) fn args
101+
102+jsAppN :: Text -> [JsExpr] -> JsExpr
103+jsAppN fn args = JsApp (JsVar fn) args
104+
105+jsStmt2Text :: JsStmt -> Text
106+jsStmt2Text JsEmpty = ""
107+jsStmt2Text (JsExprStmt e) = T.concat [jsAst2Text e, ";"]
108+jsStmt2Text (JsReturn x) = T.concat ["return ", jsAst2Text x, ";"]
109+jsStmt2Text (JsDecVar name exp) =
110+ T.concat ["var ", name, " = ", jsAst2Text exp, ";"]
111+jsStmt2Text (JsDecConst name exp) =
112+ T.concat ["const ", name, " = ", jsAst2Text exp, ";"]
113+jsStmt2Text (JsDecLet name exp) =
114+ T.concat ["let ", name, " = ", jsAst2Text exp, ";"]
115+jsStmt2Text (JsFun name args body) =
116+ T.concat
117+ [ "function "
118+ , name
119+ , "("
120+ , T.intercalate ", " args
121+ , "){\n"
122+ , indent $ jsStmt2Text body
123+ , "}\n"
124+ ]
125+jsStmt2Text (JsIf cond conseq (Just next@(JsIf _ _ _))) =
126+ T.concat
127+ [ "if("
128+ , jsAst2Text cond
129+ , ") {\n"
130+ , indent $ jsStmt2Text conseq
131+ , "} else "
132+ , jsStmt2Text next
133+ ]
134+jsStmt2Text (JsIf cond conseq (Just alt)) =
135+ T.concat
136+ [ "if("
137+ , jsAst2Text cond
138+ , ") {\n"
139+ , indent $ jsStmt2Text conseq
140+ , "} else {\n"
141+ , indent $ jsStmt2Text alt
142+ , "}\n"
143+ ]
144+jsStmt2Text (JsIf cond conseq Nothing) =
145+ T.concat ["if(", jsAst2Text cond, ") {\n", indent $ jsStmt2Text conseq, "}\n"]
146+jsStmt2Text (JsSwitchCase exp l d) =
147+ T.concat
148+ [ "switch("
149+ , jsAst2Text exp
150+ , "){\n"
151+ , indent $ T.concat $ map case2Text l
152+ , indent $ default2Text d
153+ , "}\n"
154+ ]
155+ where
156+ case2Text :: (JsExpr, JsStmt) -> Text
157+ case2Text (x, y) =
158+ T.concat
159+ [ "case "
160+ , jsAst2Text x
161+ , ":\n"
162+ , indent $ T.concat [jsStmt2Text y, ";\nbreak;\n"]
163+ ]
164+ default2Text :: Maybe JsStmt -> Text
165+ default2Text Nothing = ""
166+ default2Text (Just z) =
167+ T.concat ["default:\n", indent $ T.concat [jsStmt2Text z, ";\nbreak;\n"]]
168+jsStmt2Text (JsError t) = T.concat ["throw new Error( ", jsAst2Text t, ");"]
169+jsStmt2Text (JsForever x) =
170+ T.concat ["for(;;) {\n", indent $ jsStmt2Text x, "}\n"]
171+jsStmt2Text JsContinue = "continue;"
172+jsStmt2Text JsBreak = "break;"
173+jsStmt2Text (JsSeq JsEmpty y) = jsStmt2Text y
174+jsStmt2Text (JsSeq x JsEmpty) = jsStmt2Text x
175+jsStmt2Text (JsSeq x y) = T.concat [jsStmt2Text x, "\n", jsStmt2Text y]
176+jsStmt2Text (JsSet term exp) =
177+ T.concat [jsAst2Text term, " = ", jsAst2Text exp, ";"]
178+
179+jsAst2Text :: JsExpr -> Text
180+jsAst2Text JsNull = "null"
181+jsAst2Text JsUndefined = "(void 0)"
182+jsAst2Text JsThis = "this"
183+jsAst2Text (JsLambda args body) =
184+ T.concat
185+ [ "(function"
186+ , "("
187+ , T.intercalate ", " args
188+ , "){\n"
189+ , indent $ jsStmt2Text body
190+ , "})"
191+ ]
192+jsAst2Text (JsApp fn args) =
193+ T.concat [jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]
194+jsAst2Text (JsMethod obj name args) =
195+ T.concat
196+ [ jsAst2Text obj
197+ , "."
198+ , name
199+ , "("
200+ , T.intercalate ", " $ map jsAst2Text args
201+ , ")"
202+ ]
203+jsAst2Text (JsPart obj name) =
204+ T.concat [jsAst2Text obj, "[", T.pack (show name), "]"]
205+jsAst2Text (JsVar x) = x
206+jsAst2Text (JsObj props) =
207+ T.concat
208+ [ "({"
209+ , T.intercalate
210+ ", "
211+ (map (\(name, val) -> T.concat [name, ": ", jsAst2Text val]) props)
212+ , "})"
213+ ]
214+jsAst2Text (JsProp object name) = T.concat [jsAst2Text object, ".", name]
215+jsAst2Text (JsArrayProj i exp) =
216+ T.concat [jsAst2Text exp, "[", jsAst2Text i, "]"]
217+jsAst2Text (JsInt i) = T.pack $ show i
218+jsAst2Text (JsBool True) = T.pack "true"
219+jsAst2Text (JsBool False) = T.pack "false"
220+jsAst2Text (JsDouble d) = T.pack $ show d
221+jsAst2Text (JsInteger i) = T.pack $ show i
222+jsAst2Text (JsStr s) = T.pack $ show s
223+jsAst2Text (JsArray l) =
224+ T.concat ["[", T.intercalate ", " (map jsAst2Text l), "]"]
225+jsAst2Text (JsErrorExp t) =
226+ T.concat ["js_idris_throw2(new Error( ", jsAst2Text t, "))"]
227+jsAst2Text (JsBinOp op a1 a2) =
228+ T.concat ["(", jsAst2Text a1, " ", op, " ", jsAst2Text a2, ")"]
229+jsAst2Text (JsUniOp op a) = T.concat ["(", op, jsAst2Text a, ")"]
230+jsAst2Text (JsForeign code args) =
231+ let args_repl c i [] = c
232+ args_repl c i (t:r) =
233+ args_repl (T.replace ("%" `T.append` T.pack (show i)) t c) (i + 1) r
234+ in T.concat ["(", args_repl code 0 (map jsAst2Text args), ")"]
235+jsAst2Text (JsB2I x) = jsAst2Text $ JsBinOp "+" x (JsInt 0)
236+jsAst2Text (JsComment c) = T.concat ["/*", c, "*/"]
237+jsAst2Text (JsForce e) = T.concat ["js_idris_force(", jsAst2Text e, ")"]
238+
239+jsLazy :: JsExpr -> JsExpr
240+jsLazy e = JsObj [("js_idris_lazy_calc", (JsLambda [] $ JsReturn e))]
241+
242+throw2 =
243+ T.concat ["var js_idris_throw2 = function (x){\n", " throw x;\n", "}\n"]
244+
245+force =
246+ T.concat
247+ [ "var js_idris_force = function (x){\n"
248+ , " if(x.js_idris_lazy_calc === undefined){\n"
249+ , " return x\n"
250+ , " }else{\n"
251+ , " if(x.js_idris_lazy_val === undefined){\n"
252+ , " x.js_idris_lazy_val = x.js_idris_lazy_calc()\n"
253+ , " }\n"
254+ , " return x.js_idris_lazy_val\n"
255+ , " }\n"
256+ , "}\n"
257+ ]
258+
259+js_aux_defs = T.concat [throw2, force]
260+
261+jsExpr2Stmt :: JsExpr -> JsStmt
262+jsExpr2Stmt = JsExprStmt
263+
264+jsStmt2Expr :: JsStmt -> JsExpr
265+jsStmt2Expr (JsExprStmt x) = x
266+jsStmt2Expr x = JsApp (JsLambda [] x) []