git.iko.soy/Idris-dev
on f0a67ff help sign in
Idris-dev/src/IRTS/JavaScript/AST.hs
411 lines 12 kB history raw
1{-|
2Module : IRTS.JavaScript.AST
3Description : Data structures and functions used with the JavaScript codegen.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE OverloadedStrings #-}
10module IRTS.JavaScript.AST where
12import Data.Word
13import Data.Char (isDigit)
15import qualified Data.Text as T
17data JSType = JSIntTy
18 | JSStringTy
19 | JSIntegerTy
20 | JSFloatTy
21 | JSCharTy
22 | JSPtrTy
23 | JSForgotTy
24 deriving Eq
27data JSInteger = JSBigZero
28 | JSBigOne
29 | JSBigInt Integer
30 | JSBigIntExpr JS
31 deriving Eq
34data JSNum = JSInt Int
35 | JSFloat Double
36 | JSInteger JSInteger
37 deriving Eq
40data JSWord = JSWord8 Word8
41 | JSWord16 Word16
42 | JSWord32 Word32
43 | JSWord64 Word64
44 deriving Eq
47data JSAnnotation = JSConstructor deriving Eq
50instance Show JSAnnotation where
51 show JSConstructor = "constructor"
54data JS = JSRaw String
55 | JSIdent String
56 | JSFunction [String] JS
57 | JSType JSType
58 | JSSeq [JS]
59 | JSReturn JS
60 | JSApp JS [JS]
61 | JSNew String [JS]
62 | JSError String
63 | JSBinOp String JS JS
64 | JSPreOp String JS
65 | JSPostOp String JS
66 | JSProj JS String
67 | JSNull
68 | JSUndefined
69 | JSThis
70 | JSTrue
71 | JSFalse
72 | JSArray [JS]
73 | JSString String
74 | JSNum JSNum
75 | JSWord JSWord
76 | JSAssign JS JS
77 | JSAlloc String (Maybe JS)
78 | JSIndex JS JS
79 | JSSwitch JS [(JS, JS)] (Maybe JS)
80 | JSCond [(JS, JS)]
81 | JSTernary JS JS JS
82 | JSParens JS
83 | JSWhile JS JS
84 | JSFFI String [JS]
85 | JSAnnotation JSAnnotation JS
86 | JSDelete JS
87 | JSClear JS
88 | JSNoop
89 deriving Eq
92data FFI = FFICode Char | FFIArg Int | FFIError String
94ffi :: String -> [String] -> T.Text
95ffi code args = let parsed = ffiParse code in
96 case ffiError parsed of
97 Just err -> error err
98 Nothing -> renderFFI parsed args
99 where
100 ffiParse :: String -> [FFI]
101 ffiParse "" = []
102 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
103 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
104 ffiParse ('%':s:ss)
105 | isDigit s =
106 FFIArg (
107 read $ s : takeWhile isDigit ss
108 ) : ffiParse (dropWhile isDigit ss)
109 | otherwise =
110 [FFIError "FFI - Invalid positional argument"]
111 ffiParse (s:ss) = FFICode s : ffiParse ss
114 ffiError :: [FFI] -> Maybe String
115 ffiError [] = Nothing
116 ffiError ((FFIError s):xs) = Just s
117 ffiError (x:xs) = ffiError xs
120 renderFFI :: [FFI] -> [String] -> T.Text
121 renderFFI [] _ = ""
122 renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args
123 renderFFI (FFIArg i : fs) args
124 | i < length args && i >= 0 =
125 T.pack (args !! i)
126 `T.append` renderFFI fs args
127 | otherwise = error "FFI - Argument index out of bounds"
129compileJS :: JS -> T.Text
130compileJS = compileJS' 0
132compileJS' :: Int -> JS -> T.Text
133compileJS' indent JSNoop = ""
135compileJS' indent (JSAnnotation annotation js) =
136 "/** @"
137 `T.append` T.pack (show annotation)
138 `T.append` " */\n"
139 `T.append` compileJS' indent js
141compileJS' indent (JSDelete js) =
142 "delete " `T.append` compileJS' 0 js
144compileJS' indent (JSClear js) =
145 compileJS' 0 js `T.append` " = undefined"
147compileJS' indent (JSFFI raw args) =
148 ffi raw (map (T.unpack . compileJS' indent) args)
150compileJS' indent (JSRaw code) =
151 T.pack code
153compileJS' indent (JSIdent ident) =
154 T.pack ident
156compileJS' indent (JSFunction args body) =
157 T.replicate indent " " `T.append` "function("
158 `T.append` T.intercalate "," (map T.pack args)
159 `T.append` "){\n"
160 `T.append` compileJS' (indent + 2) body
161 `T.append` "\n}\n"
163compileJS' indent (JSType ty)
164 | JSIntTy <- ty = "i$Int"
165 | JSStringTy <- ty = "i$String"
166 | JSIntegerTy <- ty = "i$Integer"
167 | JSFloatTy <- ty = "i$Float"
168 | JSCharTy <- ty = "i$Char"
169 | JSPtrTy <- ty = "i$Ptr"
170 | JSForgotTy <- ty = "i$Forgot"
172compileJS' indent (JSSeq seq) =
173 T.intercalate ";\n" (
174 map (
175 (T.replicate indent " " `T.append`) . (compileJS' indent)
176 ) $ filter (/= JSNoop) seq
177 ) `T.append` ";"
179compileJS' indent (JSReturn val) =
180 "return " `T.append` compileJS' indent val
182compileJS' indent (JSApp lhs rhs)
183 | JSFunction {} <- lhs =
184 T.concat ["(", compileJS' indent lhs, ")(", args, ")"]
185 | otherwise =
186 T.concat [compileJS' indent lhs, "(", args, ")"]
187 where args :: T.Text
188 args = T.intercalate "," $ map (compileJS' 0) rhs
190compileJS' indent (JSNew name args) =
191 "new "
192 `T.append` T.pack name
193 `T.append` "("
194 `T.append` T.intercalate "," (map (compileJS' 0) args)
195 `T.append` ")"
197compileJS' indent (JSError exc) =
198 "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"
200compileJS' indent (JSBinOp op lhs rhs) =
201 compileJS' indent lhs
202 `T.append` " "
203 `T.append` T.pack op
204 `T.append` " "
205 `T.append` compileJS' indent rhs
207compileJS' indent (JSPreOp op val) =
208 T.pack op `T.append` "(" `T.append` compileJS' indent val `T.append` ")"
210compileJS' indent (JSProj obj field)
211 | JSFunction {} <- obj =
212 T.concat ["(", compileJS' indent obj, ").", T.pack field]
213 | JSAssign {} <- obj =
214 T.concat ["(", compileJS' indent obj, ").", T.pack field]
215 | otherwise =
216 compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)
218compileJS' indent JSNull =
219 "null"
221compileJS' indent JSUndefined =
222 "undefined"
224compileJS' indent JSThis =
225 "this"
227compileJS' indent JSTrue =
228 "true"
230compileJS' indent JSFalse =
231 "false"
233compileJS' indent (JSArray elems) =
234 "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"
236compileJS' indent (JSString str) =
237 "\"" `T.append` T.pack str `T.append` "\""
239compileJS' indent (JSNum num)
240 | JSInt i <- num = T.pack (show i)
241 | JSFloat f <- num = T.pack (show f)
242 | JSInteger JSBigZero <- num = T.pack "i$ZERO"
243 | JSInteger JSBigOne <- num = T.pack "i$ONE"
244 | JSInteger (JSBigInt i) <- num = T.pack (show i)
245 | JSInteger (JSBigIntExpr e) <- num =
246 "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"
248compileJS' indent (JSAssign lhs rhs) =
249 compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs
251compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
252 "var "
253 `T.append` T.pack name
254 `T.append` " = "
255 `T.append` compileJS' 0 val
256 `T.append` ";\n"
258compileJS' indent (JSAlloc name val) =
259 "var "
260 `T.append` T.pack name
261 `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val
263compileJS' indent (JSIndex lhs rhs) =
264 compileJS' indent lhs
265 `T.append` "["
266 `T.append` compileJS' indent rhs
267 `T.append` "]"
269compileJS' indent (JSCond branches) =
270 T.intercalate " else " $ map createIfBlock branches
271 where
272 createIfBlock (JSNoop, e@(JSSeq _)) =
273 "{\n"
274 `T.append` compileJS' (indent + 2) e
275 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
276 createIfBlock (JSNoop, e) =
277 "{\n"
278 `T.append` compileJS' (indent + 2) e
279 `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"
280 createIfBlock (cond, e@(JSSeq _)) =
281 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
282 `T.append` compileJS' (indent + 2) e
283 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
284 createIfBlock (cond, e) =
285 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
286 `T.append` T.replicate (indent + 2) " "
287 `T.append` compileJS' (indent + 2) e
288 `T.append` ";\n"
289 `T.append` T.replicate indent " "
290 `T.append` "}"
292compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
293 let (h,t) = splitAt 1 seq in
294 (T.concat (map (compileJS' indent) h) `T.append` ";\n")
295 `T.append` (
296 T.intercalate ";\n" $ map (
297 (T.replicate indent " " `T.append`) . compileJS' indent
298 ) t
299 )
301compileJS' indent (JSSwitch val branches def) =
302 "switch(" `T.append` compileJS' indent val `T.append` "){\n"
303 `T.append` T.concat (map mkBranch branches)
304 `T.append` mkDefault def
305 `T.append` T.replicate indent " " `T.append` "}"
306 where
307 mkBranch :: (JS, JS) -> T.Text
308 mkBranch (tag, code) =
309 T.replicate (indent + 2) " "
310 `T.append` "case "
311 `T.append` compileJS' indent tag
312 `T.append` ":\n"
313 `T.append` compileJS' (indent + 4) code
314 `T.append` "\n"
315 `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")
317 mkDefault :: Maybe JS -> T.Text
318 mkDefault Nothing = ""
319 mkDefault (Just def) =
320 T.replicate (indent + 2) " " `T.append` "default:\n"
321 `T.append` compileJS' (indent + 4)def
322 `T.append` "\n"
325compileJS' indent (JSTernary cond true false) =
326 let c = compileJS' indent cond
327 t = compileJS' indent true
328 f = compileJS' indent false in
329 "("
330 `T.append` c
331 `T.append` ")?("
332 `T.append` t
333 `T.append` "):("
334 `T.append` f
335 `T.append` ")"
337compileJS' indent (JSParens js) =
338 "(" `T.append` compileJS' indent js `T.append` ")"
340compileJS' indent (JSWhile cond body) =
341 "while (" `T.append` compileJS' indent cond `T.append` ") {\n"
342 `T.append` compileJS' (indent + 2) body
343 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
345compileJS' indent (JSWord word)
346 | JSWord8 b <- word =
347 "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"
348 | JSWord16 b <- word =
349 "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"
350 | JSWord32 b <- word =
351 "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"
352 | JSWord64 b <- word =
353 "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"
355jsInstanceOf :: JS -> String -> JS
356jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
358jsOr :: JS -> JS -> JS
359jsOr lhs rhs = JSBinOp "||" lhs rhs
361jsAnd :: JS -> JS -> JS
362jsAnd lhs rhs = JSBinOp "&&" lhs rhs
364jsMeth :: JS -> String -> [JS] -> JS
365jsMeth obj meth args = JSApp (JSProj obj meth) args
367jsCall :: String -> [JS] -> JS
368jsCall fun args = JSApp (JSIdent fun) args
370jsTypeOf :: JS -> JS
371jsTypeOf js = JSPreOp "typeof " js
373jsEq :: JS -> JS -> JS
374jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
375jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
376jsEq lhs rhs = JSBinOp "==" lhs rhs
378jsNotEq :: JS -> JS -> JS
379jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
381jsIsNumber :: JS -> JS
382jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
384jsIsNull :: JS -> JS
385jsIsNull js = JSBinOp "==" js JSNull
387jsBigInt :: JS -> JS
388jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
389jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
390jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
392jsUnPackBits :: JS -> JS
393jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
395jsPackUBits8 :: JS -> JS
396jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
398jsPackUBits16 :: JS -> JS
399jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
401jsPackUBits32 :: JS -> JS
402jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
404jsPackSBits8 :: JS -> JS
405jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
407jsPackSBits16 :: JS -> JS
408jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
410jsPackSBits32 :: JS -> JS
411jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]