git.iko.soy/Idris-dev
on dadfc86 help sign in
Idris-dev/src/IRTS/JavaScript/AST.hs
397 lines 11 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 | JSNoop
80 deriving Eq
83data FFI = FFICode Char | FFIArg Int | FFIError String
85ffi :: String -> [String] -> T.Text
86ffi code args = let parsed = ffiParse code in
87 case ffiError parsed of
88 Just err -> error err
89 Nothing -> renderFFI parsed args
90 where
91 ffiParse :: String -> [FFI]
92 ffiParse "" = []
93 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
94 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
95 ffiParse ('%':s:ss)
96 | isDigit s =
97 FFIArg (
98 read $ s : takeWhile isDigit ss
99 ) : ffiParse (dropWhile isDigit ss)
100 | otherwise =
101 [FFIError "FFI - Invalid positional argument"]
102 ffiParse (s:ss) = FFICode s : ffiParse ss
105 ffiError :: [FFI] -> Maybe String
106 ffiError [] = Nothing
107 ffiError ((FFIError s):xs) = Just s
108 ffiError (x:xs) = ffiError xs
111 renderFFI :: [FFI] -> [String] -> T.Text
112 renderFFI [] _ = ""
113 renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args
114 renderFFI (FFIArg i : fs) args
115 | i < length args && i >= 0 =
116 T.pack (args !! i)
117 `T.append` renderFFI fs args
118 | otherwise = error "FFI - Argument index out of bounds"
120compileJS :: JS -> T.Text
121compileJS = compileJS' 0
123compileJS' :: Int -> JS -> T.Text
124compileJS' indent JSNoop = ""
126compileJS' indent (JSAnnotation annotation js) =
127 "/** @"
128 `T.append` T.pack (show annotation)
129 `T.append` " */\n"
130 `T.append` compileJS' indent js
132compileJS' indent (JSFFI raw args) =
133 ffi raw (map (T.unpack . compileJS' indent) args)
135compileJS' indent (JSRaw code) =
136 T.pack code
138compileJS' indent (JSIdent ident) =
139 T.pack ident
141compileJS' indent (JSFunction args body) =
142 T.replicate indent " " `T.append` "function("
143 `T.append` T.intercalate "," (map T.pack args)
144 `T.append` "){\n"
145 `T.append` compileJS' (indent + 2) body
146 `T.append` "\n}\n"
148compileJS' indent (JSType ty)
149 | JSIntTy <- ty = "i$Int"
150 | JSStringTy <- ty = "i$String"
151 | JSIntegerTy <- ty = "i$Integer"
152 | JSFloatTy <- ty = "i$Float"
153 | JSCharTy <- ty = "i$Char"
154 | JSPtrTy <- ty = "i$Ptr"
155 | JSForgotTy <- ty = "i$Forgot"
157compileJS' indent (JSSeq seq) =
158 T.intercalate ";\n" (
159 map (
160 (T.replicate indent " " `T.append`) . (compileJS' indent)
161 ) $ filter (/= JSNoop) seq
162 ) `T.append` ";"
164compileJS' indent (JSReturn val) =
165 "return " `T.append` compileJS' indent val
167compileJS' indent (JSApp lhs rhs)
168 | JSFunction {} <- lhs =
169 T.concat ["(", compileJS' indent lhs, ")(", args, ")"]
170 | otherwise =
171 T.concat [compileJS' indent lhs, "(", args, ")"]
172 where args :: T.Text
173 args = T.intercalate "," $ map (compileJS' 0) rhs
175compileJS' indent (JSNew name args) =
176 "new "
177 `T.append` T.pack name
178 `T.append` "("
179 `T.append` T.intercalate "," (map (compileJS' 0) args)
180 `T.append` ")"
182compileJS' indent (JSError exc) =
183 "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"
185compileJS' indent (JSBinOp op lhs rhs) =
186 compileJS' indent lhs
187 `T.append` " "
188 `T.append` T.pack op
189 `T.append` " "
190 `T.append` compileJS' indent rhs
192compileJS' indent (JSPreOp op val) =
193 T.pack op `T.append` compileJS' indent val
195compileJS' indent (JSProj obj field)
196 | JSFunction {} <- obj =
197 T.concat ["(", compileJS' indent obj, ").", T.pack field]
198 | JSAssign {} <- obj =
199 T.concat ["(", compileJS' indent obj, ").", T.pack field]
200 | otherwise =
201 compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)
203compileJS' indent JSNull =
204 "null"
206compileJS' indent JSUndefined =
207 "undefined"
209compileJS' indent JSThis =
210 "this"
212compileJS' indent JSTrue =
213 "true"
215compileJS' indent JSFalse =
216 "false"
218compileJS' indent (JSArray elems) =
219 "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"
221compileJS' indent (JSString str) =
222 "\"" `T.append` T.pack str `T.append` "\""
224compileJS' indent (JSNum num)
225 | JSInt i <- num = T.pack (show i)
226 | JSFloat f <- num = T.pack (show f)
227 | JSInteger JSBigZero <- num = T.pack "i$ZERO"
228 | JSInteger JSBigOne <- num = T.pack "i$ONE"
229 | JSInteger (JSBigInt i) <- num = T.pack (show i)
230 | JSInteger (JSBigIntExpr e) <- num =
231 "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"
233compileJS' indent (JSAssign lhs rhs) =
234 compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs
236compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
237 "var "
238 `T.append` T.pack name
239 `T.append` " = "
240 `T.append` compileJS' 0 val
241 `T.append` ";\n"
243compileJS' indent (JSAlloc name val) =
244 "var "
245 `T.append` T.pack name
246 `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val
248compileJS' indent (JSIndex lhs rhs) =
249 compileJS' indent lhs
250 `T.append` "["
251 `T.append` compileJS' indent rhs
252 `T.append` "]"
254compileJS' indent (JSCond branches) =
255 T.intercalate " else " $ map createIfBlock branches
256 where
257 createIfBlock (JSNoop, e@(JSSeq _)) =
258 "{\n"
259 `T.append` compileJS' (indent + 2) e
260 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
261 createIfBlock (JSNoop, e) =
262 "{\n"
263 `T.append` compileJS' (indent + 2) e
264 `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"
265 createIfBlock (cond, e@(JSSeq _)) =
266 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
267 `T.append` compileJS' (indent + 2) e
268 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
269 createIfBlock (cond, e) =
270 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
271 `T.append` T.replicate (indent + 2) " "
272 `T.append` compileJS' (indent + 2) e
273 `T.append` ";\n"
274 `T.append` T.replicate indent " "
275 `T.append` "}"
277compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
278 let (h,t) = splitAt 1 seq in
279 (T.concat (map (compileJS' indent) h) `T.append` ";\n")
280 `T.append` (
281 T.intercalate ";\n" $ map (
282 (T.replicate indent " " `T.append`) . compileJS' indent
283 ) t
284 )
286compileJS' indent (JSSwitch val branches def) =
287 "switch(" `T.append` compileJS' indent val `T.append` "){\n"
288 `T.append` T.concat (map mkBranch branches)
289 `T.append` mkDefault def
290 `T.append` T.replicate indent " " `T.append` "}"
291 where
292 mkBranch :: (JS, JS) -> T.Text
293 mkBranch (tag, code) =
294 T.replicate (indent + 2) " "
295 `T.append` "case "
296 `T.append` compileJS' indent tag
297 `T.append` ":\n"
298 `T.append` compileJS' (indent + 4) code
299 `T.append` "\n"
300 `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")
302 mkDefault :: Maybe JS -> T.Text
303 mkDefault Nothing = ""
304 mkDefault (Just def) =
305 T.replicate (indent + 2) " " `T.append` "default:\n"
306 `T.append` compileJS' (indent + 4)def
307 `T.append` "\n"
310compileJS' indent (JSTernary cond true false) =
311 let c = compileJS' indent cond
312 t = compileJS' indent true
313 f = compileJS' indent false in
314 "("
315 `T.append` c
316 `T.append` ")?("
317 `T.append` t
318 `T.append` "):("
319 `T.append` f
320 `T.append` ")"
322compileJS' indent (JSParens js) =
323 "(" `T.append` compileJS' indent js `T.append` ")"
325compileJS' indent (JSWhile cond body) =
326 "while (" `T.append` compileJS' indent cond `T.append` ") {\n"
327 `T.append` compileJS' (indent + 2) body
328 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
330compileJS' indent (JSWord word)
331 | JSWord8 b <- word =
332 "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"
333 | JSWord16 b <- word =
334 "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"
335 | JSWord32 b <- word =
336 "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"
337 | JSWord64 b <- word =
338 "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"
340jsInstanceOf :: JS -> String -> JS
341jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
343jsOr :: JS -> JS -> JS
344jsOr lhs rhs = JSBinOp "||" lhs rhs
346jsAnd :: JS -> JS -> JS
347jsAnd lhs rhs = JSBinOp "&&" lhs rhs
349jsMeth :: JS -> String -> [JS] -> JS
350jsMeth obj meth args = JSApp (JSProj obj meth) args
352jsCall :: String -> [JS] -> JS
353jsCall fun args = JSApp (JSIdent fun) args
355jsTypeOf :: JS -> JS
356jsTypeOf js = JSPreOp "typeof " js
358jsEq :: JS -> JS -> JS
359jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
360jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
361jsEq lhs rhs = JSBinOp "==" lhs rhs
363jsNotEq :: JS -> JS -> JS
364jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
366jsIsNumber :: JS -> JS
367jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
369jsIsNull :: JS -> JS
370jsIsNull js = JSBinOp "==" js JSNull
372jsBigInt :: JS -> JS
373jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
374jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
375jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
377jsUnPackBits :: JS -> JS
378jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
380jsPackUBits8 :: JS -> JS
381jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
383jsPackUBits16 :: JS -> JS
384jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
386jsPackUBits32 :: JS -> JS
387jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
389jsPackSBits8 :: JS -> JS
390jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
392jsPackSBits16 :: JS -> JS
393jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
395jsPackSBits32 :: JS -> JS
396jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]