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