git.iko.soy/Idris-dev
on 2cfbee4 help sign in
Idris-dev/src/IRTS/JavaScript/AST.hs
404 lines 12 kB history raw
1{-# LANGUAGE PatternGuards #-}
2{-# LANGUAGE OverloadedStrings #-}
3module IRTS.JavaScript.AST where
5import Data.Word
6import Data.Char (isDigit)
8import qualified Data.Text as T
10data JSType = JSIntTy
11 | JSStringTy
12 | JSIntegerTy
13 | JSFloatTy
14 | JSCharTy
15 | JSPtrTy
16 | JSForgotTy
17 deriving Eq
20data JSInteger = JSBigZero
21 | JSBigOne
22 | JSBigInt Integer
23 | JSBigIntExpr JS
24 deriving Eq
27data JSNum = JSInt Int
28 | JSFloat Double
29 | JSInteger JSInteger
30 deriving Eq
33data JSWord = JSWord8 Word8
34 | JSWord16 Word16
35 | JSWord32 Word32
36 | JSWord64 Word64
37 deriving Eq
40data JSAnnotation = JSConstructor deriving Eq
43instance Show JSAnnotation where
44 show JSConstructor = "constructor"
47data JS = JSRaw String
48 | JSIdent String
49 | JSFunction [String] JS
50 | JSType JSType
51 | JSSeq [JS]
52 | JSReturn JS
53 | JSApp JS [JS]
54 | JSNew String [JS]
55 | JSError String
56 | JSBinOp String JS JS
57 | JSPreOp String JS
58 | JSPostOp String JS
59 | JSProj JS String
60 | JSNull
61 | JSUndefined
62 | JSThis
63 | JSTrue
64 | JSFalse
65 | JSArray [JS]
66 | JSString String
67 | JSNum JSNum
68 | JSWord JSWord
69 | JSAssign JS JS
70 | JSAlloc String (Maybe JS)
71 | JSIndex JS JS
72 | JSSwitch JS [(JS, JS)] (Maybe JS)
73 | JSCond [(JS, JS)]
74 | JSTernary JS JS JS
75 | JSParens JS
76 | JSWhile JS JS
77 | JSFFI String [JS]
78 | JSAnnotation JSAnnotation JS
79 | JSDelete JS
80 | JSClear JS
81 | JSNoop
82 deriving Eq
85data FFI = FFICode Char | FFIArg Int | FFIError String
87ffi :: String -> [String] -> T.Text
88ffi code args = let parsed = ffiParse code in
89 case ffiError parsed of
90 Just err -> error err
91 Nothing -> renderFFI parsed args
92 where
93 ffiParse :: String -> [FFI]
94 ffiParse "" = []
95 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
96 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
97 ffiParse ('%':s:ss)
98 | isDigit s =
99 FFIArg (
100 read $ s : takeWhile isDigit ss
101 ) : ffiParse (dropWhile isDigit ss)
102 | otherwise =
103 [FFIError "FFI - Invalid positional argument"]
104 ffiParse (s:ss) = FFICode s : ffiParse ss
107 ffiError :: [FFI] -> Maybe String
108 ffiError [] = Nothing
109 ffiError ((FFIError s):xs) = Just s
110 ffiError (x:xs) = ffiError xs
113 renderFFI :: [FFI] -> [String] -> T.Text
114 renderFFI [] _ = ""
115 renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args
116 renderFFI (FFIArg i : fs) args
117 | i < length args && i >= 0 =
118 T.pack (args !! i)
119 `T.append` renderFFI fs args
120 | otherwise = error "FFI - Argument index out of bounds"
122compileJS :: JS -> T.Text
123compileJS = compileJS' 0
125compileJS' :: Int -> JS -> T.Text
126compileJS' indent JSNoop = ""
128compileJS' indent (JSAnnotation annotation js) =
129 "/** @"
130 `T.append` T.pack (show annotation)
131 `T.append` " */\n"
132 `T.append` compileJS' indent js
134compileJS' indent (JSDelete js) =
135 "delete " `T.append` compileJS' 0 js
137compileJS' indent (JSClear js) =
138 compileJS' 0 js `T.append` " = undefined"
140compileJS' indent (JSFFI raw args) =
141 ffi raw (map (T.unpack . compileJS' indent) args)
143compileJS' indent (JSRaw code) =
144 T.pack code
146compileJS' indent (JSIdent ident) =
147 T.pack ident
149compileJS' indent (JSFunction args body) =
150 T.replicate indent " " `T.append` "function("
151 `T.append` T.intercalate "," (map T.pack args)
152 `T.append` "){\n"
153 `T.append` compileJS' (indent + 2) body
154 `T.append` "\n}\n"
156compileJS' indent (JSType ty)
157 | JSIntTy <- ty = "i$Int"
158 | JSStringTy <- ty = "i$String"
159 | JSIntegerTy <- ty = "i$Integer"
160 | JSFloatTy <- ty = "i$Float"
161 | JSCharTy <- ty = "i$Char"
162 | JSPtrTy <- ty = "i$Ptr"
163 | JSForgotTy <- ty = "i$Forgot"
165compileJS' indent (JSSeq seq) =
166 T.intercalate ";\n" (
167 map (
168 (T.replicate indent " " `T.append`) . (compileJS' indent)
169 ) $ filter (/= JSNoop) seq
170 ) `T.append` ";"
172compileJS' indent (JSReturn val) =
173 "return " `T.append` compileJS' indent val
175compileJS' indent (JSApp lhs rhs)
176 | JSFunction {} <- lhs =
177 T.concat ["(", compileJS' indent lhs, ")(", args, ")"]
178 | otherwise =
179 T.concat [compileJS' indent lhs, "(", args, ")"]
180 where args :: T.Text
181 args = T.intercalate "," $ map (compileJS' 0) rhs
183compileJS' indent (JSNew name args) =
184 "new "
185 `T.append` T.pack name
186 `T.append` "("
187 `T.append` T.intercalate "," (map (compileJS' 0) args)
188 `T.append` ")"
190compileJS' indent (JSError exc) =
191 "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"
193compileJS' indent (JSBinOp op lhs rhs) =
194 compileJS' indent lhs
195 `T.append` " "
196 `T.append` T.pack op
197 `T.append` " "
198 `T.append` compileJS' indent rhs
200compileJS' indent (JSPreOp op val) =
201 T.pack op `T.append` "(" `T.append` compileJS' indent val `T.append` ")"
203compileJS' indent (JSProj obj field)
204 | JSFunction {} <- obj =
205 T.concat ["(", compileJS' indent obj, ").", T.pack field]
206 | JSAssign {} <- obj =
207 T.concat ["(", compileJS' indent obj, ").", T.pack field]
208 | otherwise =
209 compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)
211compileJS' indent JSNull =
212 "null"
214compileJS' indent JSUndefined =
215 "undefined"
217compileJS' indent JSThis =
218 "this"
220compileJS' indent JSTrue =
221 "true"
223compileJS' indent JSFalse =
224 "false"
226compileJS' indent (JSArray elems) =
227 "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"
229compileJS' indent (JSString str) =
230 "\"" `T.append` T.pack str `T.append` "\""
232compileJS' indent (JSNum num)
233 | JSInt i <- num = T.pack (show i)
234 | JSFloat f <- num = T.pack (show f)
235 | JSInteger JSBigZero <- num = T.pack "i$ZERO"
236 | JSInteger JSBigOne <- num = T.pack "i$ONE"
237 | JSInteger (JSBigInt i) <- num = T.pack (show i)
238 | JSInteger (JSBigIntExpr e) <- num =
239 "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"
241compileJS' indent (JSAssign lhs rhs) =
242 compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs
244compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
245 "var "
246 `T.append` T.pack name
247 `T.append` " = "
248 `T.append` compileJS' 0 val
249 `T.append` ";\n"
251compileJS' indent (JSAlloc name val) =
252 "var "
253 `T.append` T.pack name
254 `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val
256compileJS' indent (JSIndex lhs rhs) =
257 compileJS' indent lhs
258 `T.append` "["
259 `T.append` compileJS' indent rhs
260 `T.append` "]"
262compileJS' indent (JSCond branches) =
263 T.intercalate " else " $ map createIfBlock branches
264 where
265 createIfBlock (JSNoop, e@(JSSeq _)) =
266 "{\n"
267 `T.append` compileJS' (indent + 2) e
268 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
269 createIfBlock (JSNoop, e) =
270 "{\n"
271 `T.append` compileJS' (indent + 2) e
272 `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"
273 createIfBlock (cond, e@(JSSeq _)) =
274 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
275 `T.append` compileJS' (indent + 2) e
276 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
277 createIfBlock (cond, e) =
278 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
279 `T.append` T.replicate (indent + 2) " "
280 `T.append` compileJS' (indent + 2) e
281 `T.append` ";\n"
282 `T.append` T.replicate indent " "
283 `T.append` "}"
285compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
286 let (h,t) = splitAt 1 seq in
287 (T.concat (map (compileJS' indent) h) `T.append` ";\n")
288 `T.append` (
289 T.intercalate ";\n" $ map (
290 (T.replicate indent " " `T.append`) . compileJS' indent
291 ) t
292 )
294compileJS' indent (JSSwitch val branches def) =
295 "switch(" `T.append` compileJS' indent val `T.append` "){\n"
296 `T.append` T.concat (map mkBranch branches)
297 `T.append` mkDefault def
298 `T.append` T.replicate indent " " `T.append` "}"
299 where
300 mkBranch :: (JS, JS) -> T.Text
301 mkBranch (tag, code) =
302 T.replicate (indent + 2) " "
303 `T.append` "case "
304 `T.append` compileJS' indent tag
305 `T.append` ":\n"
306 `T.append` compileJS' (indent + 4) code
307 `T.append` "\n"
308 `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")
310 mkDefault :: Maybe JS -> T.Text
311 mkDefault Nothing = ""
312 mkDefault (Just def) =
313 T.replicate (indent + 2) " " `T.append` "default:\n"
314 `T.append` compileJS' (indent + 4)def
315 `T.append` "\n"
318compileJS' indent (JSTernary cond true false) =
319 let c = compileJS' indent cond
320 t = compileJS' indent true
321 f = compileJS' indent false in
322 "("
323 `T.append` c
324 `T.append` ")?("
325 `T.append` t
326 `T.append` "):("
327 `T.append` f
328 `T.append` ")"
330compileJS' indent (JSParens js) =
331 "(" `T.append` compileJS' indent js `T.append` ")"
333compileJS' indent (JSWhile cond body) =
334 "while (" `T.append` compileJS' indent cond `T.append` ") {\n"
335 `T.append` compileJS' (indent + 2) body
336 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
338compileJS' indent (JSWord word)
339 | JSWord8 b <- word =
340 "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"
341 | JSWord16 b <- word =
342 "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"
343 | JSWord32 b <- word =
344 "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"
345 | JSWord64 b <- word =
346 "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"
348jsInstanceOf :: JS -> String -> JS
349jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
351jsOr :: JS -> JS -> JS
352jsOr lhs rhs = JSBinOp "||" lhs rhs
354jsAnd :: JS -> JS -> JS
355jsAnd lhs rhs = JSBinOp "&&" lhs rhs
357jsMeth :: JS -> String -> [JS] -> JS
358jsMeth obj meth args = JSApp (JSProj obj meth) args
360jsCall :: String -> [JS] -> JS
361jsCall fun args = JSApp (JSIdent fun) args
363jsTypeOf :: JS -> JS
364jsTypeOf js = JSPreOp "typeof " js
366jsEq :: JS -> JS -> JS
367jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
368jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
369jsEq lhs rhs = JSBinOp "==" lhs rhs
371jsNotEq :: JS -> JS -> JS
372jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
374jsIsNumber :: JS -> JS
375jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
377jsIsNull :: JS -> JS
378jsIsNull js = JSBinOp "==" js JSNull
380jsBigInt :: JS -> JS
381jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
382jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
383jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
385jsUnPackBits :: JS -> JS
386jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
388jsPackUBits8 :: JS -> JS
389jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
391jsPackUBits16 :: JS -> JS
392jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
394jsPackUBits32 :: JS -> JS
395jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
397jsPackSBits8 :: JS -> JS
398jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
400jsPackSBits16 :: JS -> JS
401jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
403jsPackSBits32 :: JS -> JS
404jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]