git.iko.soy/Idris-dev
on 735fbd2 help sign in
Idris-dev/src/IRTS/JavaScript/AST.hs
409 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 OverloadedStrings, PatternGuards #-}
9module IRTS.JavaScript.AST where
11import Data.Char (isDigit)
12import qualified Data.Text as T
13import Data.Word
15data JSType = JSIntTy
16 | JSStringTy
17 | JSIntegerTy
18 | JSFloatTy
19 | JSCharTy
20 | JSPtrTy
21 | JSForgotTy
22 deriving Eq
25data JSInteger = JSBigZero
26 | JSBigOne
27 | JSBigInt Integer
28 | JSBigIntExpr JS
29 deriving Eq
32data JSNum = JSInt Int
33 | JSFloat Double
34 | JSInteger JSInteger
35 deriving Eq
38data JSWord = JSWord8 Word8
39 | JSWord16 Word16
40 | JSWord32 Word32
41 | JSWord64 Word64
42 deriving Eq
45data JSAnnotation = JSConstructor deriving Eq
48instance Show JSAnnotation where
49 show JSConstructor = "constructor"
52data JS = JSRaw String
53 | JSIdent String
54 | JSFunction [String] JS
55 | JSType JSType
56 | JSSeq [JS]
57 | JSReturn JS
58 | JSApp JS [JS]
59 | JSNew String [JS]
60 | JSError String
61 | JSBinOp String JS JS
62 | JSPreOp String JS
63 | JSPostOp String JS
64 | JSProj JS String
65 | JSNull
66 | JSUndefined
67 | JSThis
68 | JSTrue
69 | JSFalse
70 | JSArray [JS]
71 | JSString String
72 | JSNum JSNum
73 | JSWord JSWord
74 | JSAssign JS JS
75 | JSAlloc String (Maybe JS)
76 | JSIndex JS JS
77 | JSSwitch JS [(JS, JS)] (Maybe JS)
78 | JSCond [(JS, JS)]
79 | JSTernary JS JS JS
80 | JSParens JS
81 | JSWhile JS JS
82 | JSFFI String [JS]
83 | JSAnnotation JSAnnotation JS
84 | JSDelete JS
85 | JSClear JS
86 | JSNoop
87 deriving Eq
90data FFI = FFICode Char | FFIArg Int | FFIError String
92ffi :: String -> [String] -> T.Text
93ffi code args = let parsed = ffiParse code in
94 case ffiError parsed of
95 Just err -> error err
96 Nothing -> renderFFI parsed args
97 where
98 ffiParse :: String -> [FFI]
99 ffiParse "" = []
100 ffiParse ['%'] = [FFIError "FFI - Invalid positional argument"]
101 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
102 ffiParse ('%':s:ss)
103 | isDigit s =
104 FFIArg (
105 read $ s : takeWhile isDigit ss
106 ) : ffiParse (dropWhile isDigit ss)
107 | otherwise =
108 [FFIError "FFI - Invalid positional argument"]
109 ffiParse (s:ss) = FFICode s : ffiParse ss
112 ffiError :: [FFI] -> Maybe String
113 ffiError [] = Nothing
114 ffiError ((FFIError s):xs) = Just s
115 ffiError (x:xs) = ffiError xs
118 renderFFI :: [FFI] -> [String] -> T.Text
119 renderFFI [] _ = ""
120 renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args
121 renderFFI (FFIArg i : fs) args
122 | i < length args && i >= 0 =
123 T.pack (args !! i)
124 `T.append` renderFFI fs args
125 | otherwise = error "FFI - Argument index out of bounds"
127compileJS :: JS -> T.Text
128compileJS = compileJS' 0
130compileJS' :: Int -> JS -> T.Text
131compileJS' indent JSNoop = ""
133compileJS' indent (JSAnnotation annotation js) =
134 "/** @"
135 `T.append` T.pack (show annotation)
136 `T.append` " */\n"
137 `T.append` compileJS' indent js
139compileJS' indent (JSDelete js) =
140 "delete " `T.append` compileJS' 0 js
142compileJS' indent (JSClear js) =
143 compileJS' 0 js `T.append` " = undefined"
145compileJS' indent (JSFFI raw args) =
146 ffi raw (map (T.unpack . compileJS' indent) args)
148compileJS' indent (JSRaw code) =
149 T.pack code
151compileJS' indent (JSIdent ident) =
152 T.pack ident
154compileJS' indent (JSFunction args body) =
155 T.replicate indent " " `T.append` "function("
156 `T.append` T.intercalate "," (map T.pack args)
157 `T.append` "){\n"
158 `T.append` compileJS' (indent + 2) body
159 `T.append` "\n}\n"
161compileJS' indent (JSType ty)
162 | JSIntTy <- ty = "i$Int"
163 | JSStringTy <- ty = "i$String"
164 | JSIntegerTy <- ty = "i$Integer"
165 | JSFloatTy <- ty = "i$Float"
166 | JSCharTy <- ty = "i$Char"
167 | JSPtrTy <- ty = "i$Ptr"
168 | JSForgotTy <- ty = "i$Forgot"
170compileJS' indent (JSSeq seq) =
171 T.intercalate ";\n" (
172 map (
173 (T.replicate indent " " `T.append`) . (compileJS' indent)
174 ) $ filter (/= JSNoop) seq
175 ) `T.append` ";"
177compileJS' indent (JSReturn val) =
178 "return " `T.append` compileJS' indent val
180compileJS' indent (JSApp lhs rhs)
181 | JSFunction {} <- lhs =
182 T.concat ["(", compileJS' indent lhs, ")(", args, ")"]
183 | otherwise =
184 T.concat [compileJS' indent lhs, "(", args, ")"]
185 where args :: T.Text
186 args = T.intercalate "," $ map (compileJS' 0) rhs
188compileJS' indent (JSNew name args) =
189 "new "
190 `T.append` T.pack name
191 `T.append` "("
192 `T.append` T.intercalate "," (map (compileJS' 0) args)
193 `T.append` ")"
195compileJS' indent (JSError exc) =
196 "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"
198compileJS' indent (JSBinOp op lhs rhs) =
199 compileJS' indent lhs
200 `T.append` " "
201 `T.append` T.pack op
202 `T.append` " "
203 `T.append` compileJS' indent rhs
205compileJS' indent (JSPreOp op val) =
206 T.pack op `T.append` "(" `T.append` compileJS' indent val `T.append` ")"
208compileJS' indent (JSProj obj field)
209 | JSFunction {} <- obj =
210 T.concat ["(", compileJS' indent obj, ").", T.pack field]
211 | JSAssign {} <- obj =
212 T.concat ["(", compileJS' indent obj, ").", T.pack field]
213 | otherwise =
214 compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)
216compileJS' indent JSNull =
217 "null"
219compileJS' indent JSUndefined =
220 "undefined"
222compileJS' indent JSThis =
223 "this"
225compileJS' indent JSTrue =
226 "true"
228compileJS' indent JSFalse =
229 "false"
231compileJS' indent (JSArray elems) =
232 "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"
234compileJS' indent (JSString str) =
235 "\"" `T.append` T.pack str `T.append` "\""
237compileJS' indent (JSNum num)
238 | JSInt i <- num = T.pack (show i)
239 | JSFloat f <- num = T.pack (show f)
240 | JSInteger JSBigZero <- num = T.pack "i$ZERO"
241 | JSInteger JSBigOne <- num = T.pack "i$ONE"
242 | JSInteger (JSBigInt i) <- num = T.pack (show i)
243 | JSInteger (JSBigIntExpr e) <- num =
244 "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"
246compileJS' indent (JSAssign lhs rhs) =
247 compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs
249compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
250 "var "
251 `T.append` T.pack name
252 `T.append` " = "
253 `T.append` compileJS' 0 val
254 `T.append` ";\n"
256compileJS' indent (JSAlloc name val) =
257 "var "
258 `T.append` T.pack name
259 `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val
261compileJS' indent (JSIndex lhs rhs) =
262 compileJS' indent lhs
263 `T.append` "["
264 `T.append` compileJS' indent rhs
265 `T.append` "]"
267compileJS' indent (JSCond branches) =
268 T.intercalate " else " $ map createIfBlock branches
269 where
270 createIfBlock (JSNoop, e@(JSSeq _)) =
271 "{\n"
272 `T.append` compileJS' (indent + 2) e
273 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
274 createIfBlock (JSNoop, e) =
275 "{\n"
276 `T.append` compileJS' (indent + 2) e
277 `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"
278 createIfBlock (cond, e@(JSSeq _)) =
279 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
280 `T.append` compileJS' (indent + 2) e
281 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
282 createIfBlock (cond, e) =
283 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
284 `T.append` T.replicate (indent + 2) " "
285 `T.append` compileJS' (indent + 2) e
286 `T.append` ";\n"
287 `T.append` T.replicate indent " "
288 `T.append` "}"
290compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
291 let (h,t) = splitAt 1 seq in
292 (T.concat (map (compileJS' indent) h) `T.append` ";\n")
293 `T.append` (
294 T.intercalate ";\n" $ map (
295 (T.replicate indent " " `T.append`) . compileJS' indent
296 ) t
297 )
299compileJS' indent (JSSwitch val branches def) =
300 "switch(" `T.append` compileJS' indent val `T.append` "){\n"
301 `T.append` T.concat (map mkBranch branches)
302 `T.append` mkDefault def
303 `T.append` T.replicate indent " " `T.append` "}"
304 where
305 mkBranch :: (JS, JS) -> T.Text
306 mkBranch (tag, code) =
307 T.replicate (indent + 2) " "
308 `T.append` "case "
309 `T.append` compileJS' indent tag
310 `T.append` ":\n"
311 `T.append` compileJS' (indent + 4) code
312 `T.append` "\n"
313 `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")
315 mkDefault :: Maybe JS -> T.Text
316 mkDefault Nothing = ""
317 mkDefault (Just def) =
318 T.replicate (indent + 2) " " `T.append` "default:\n"
319 `T.append` compileJS' (indent + 4)def
320 `T.append` "\n"
323compileJS' indent (JSTernary cond true false) =
324 let c = compileJS' indent cond
325 t = compileJS' indent true
326 f = compileJS' indent false in
327 "("
328 `T.append` c
329 `T.append` ")?("
330 `T.append` t
331 `T.append` "):("
332 `T.append` f
333 `T.append` ")"
335compileJS' indent (JSParens js) =
336 "(" `T.append` compileJS' indent js `T.append` ")"
338compileJS' indent (JSWhile cond body) =
339 "while (" `T.append` compileJS' indent cond `T.append` ") {\n"
340 `T.append` compileJS' (indent + 2) body
341 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
343compileJS' indent (JSWord word)
344 | JSWord8 b <- word =
345 "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"
346 | JSWord16 b <- word =
347 "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"
348 | JSWord32 b <- word =
349 "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"
350 | JSWord64 b <- word =
351 "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"
353jsInstanceOf :: JS -> String -> JS
354jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
356jsOr :: JS -> JS -> JS
357jsOr lhs rhs = JSBinOp "||" lhs rhs
359jsAnd :: JS -> JS -> JS
360jsAnd lhs rhs = JSBinOp "&&" lhs rhs
362jsMeth :: JS -> String -> [JS] -> JS
363jsMeth obj meth args = JSApp (JSProj obj meth) args
365jsCall :: String -> [JS] -> JS
366jsCall fun args = JSApp (JSIdent fun) args
368jsTypeOf :: JS -> JS
369jsTypeOf js = JSPreOp "typeof " js
371jsEq :: JS -> JS -> JS
372jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
373jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
374jsEq lhs rhs = JSBinOp "==" lhs rhs
376jsNotEq :: JS -> JS -> JS
377jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
379jsIsNumber :: JS -> JS
380jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
382jsIsNull :: JS -> JS
383jsIsNull js = JSBinOp "==" js JSNull
385jsBigInt :: JS -> JS
386jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
387jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
388jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
390jsUnPackBits :: JS -> JS
391jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
393jsPackUBits8 :: JS -> JS
394jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
396jsPackUBits16 :: JS -> JS
397jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
399jsPackUBits32 :: JS -> JS
400jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
402jsPackSBits8 :: JS -> JS
403jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
405jsPackSBits16 :: JS -> JS
406jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
408jsPackSBits32 :: JS -> JS
409jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]