git.iko.soy/Idris-dev
on cf47310 help sign in
Idris-dev/src/IRTS/JavaScript/AST.hs
401 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 | JSDelete JS
80 | JSNoop
81 deriving Eq
84data FFI = FFICode Char | FFIArg Int | FFIError String
86ffi :: String -> [String] -> T.Text
87ffi code args = let parsed = ffiParse code in
88 case ffiError parsed of
89 Just err -> error err
90 Nothing -> renderFFI parsed args
91 where
92 ffiParse :: String -> [FFI]
93 ffiParse "" = []
94 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
95 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
96 ffiParse ('%':s:ss)
97 | isDigit s =
98 FFIArg (
99 read $ s : takeWhile isDigit ss
100 ) : ffiParse (dropWhile isDigit ss)
101 | otherwise =
102 [FFIError "FFI - Invalid positional argument"]
103 ffiParse (s:ss) = FFICode s : ffiParse ss
106 ffiError :: [FFI] -> Maybe String
107 ffiError [] = Nothing
108 ffiError ((FFIError s):xs) = Just s
109 ffiError (x:xs) = ffiError xs
112 renderFFI :: [FFI] -> [String] -> T.Text
113 renderFFI [] _ = ""
114 renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args
115 renderFFI (FFIArg i : fs) args
116 | i < length args && i >= 0 =
117 T.pack (args !! i)
118 `T.append` renderFFI fs args
119 | otherwise = error "FFI - Argument index out of bounds"
121compileJS :: JS -> T.Text
122compileJS = compileJS' 0
124compileJS' :: Int -> JS -> T.Text
125compileJS' indent JSNoop = ""
127compileJS' indent (JSAnnotation annotation js) =
128 "/** @"
129 `T.append` T.pack (show annotation)
130 `T.append` " */\n"
131 `T.append` compileJS' indent js
133compileJS' indent (JSDelete js) =
134 "delete " `T.append` compileJS' 0 js
136compileJS' indent (JSFFI raw args) =
137 ffi raw (map (T.unpack . compileJS' indent) args)
139compileJS' indent (JSRaw code) =
140 T.pack code
142compileJS' indent (JSIdent ident) =
143 T.pack ident
145compileJS' indent (JSFunction args body) =
146 T.replicate indent " " `T.append` "function("
147 `T.append` T.intercalate "," (map T.pack args)
148 `T.append` "){\n"
149 `T.append` compileJS' (indent + 2) body
150 `T.append` "\n}\n"
152compileJS' indent (JSType ty)
153 | JSIntTy <- ty = "i$Int"
154 | JSStringTy <- ty = "i$String"
155 | JSIntegerTy <- ty = "i$Integer"
156 | JSFloatTy <- ty = "i$Float"
157 | JSCharTy <- ty = "i$Char"
158 | JSPtrTy <- ty = "i$Ptr"
159 | JSForgotTy <- ty = "i$Forgot"
161compileJS' indent (JSSeq seq) =
162 T.intercalate ";\n" (
163 map (
164 (T.replicate indent " " `T.append`) . (compileJS' indent)
165 ) $ filter (/= JSNoop) seq
166 ) `T.append` ";"
168compileJS' indent (JSReturn val) =
169 "return " `T.append` compileJS' indent val
171compileJS' indent (JSApp lhs rhs)
172 | JSFunction {} <- lhs =
173 T.concat ["(", compileJS' indent lhs, ")(", args, ")"]
174 | otherwise =
175 T.concat [compileJS' indent lhs, "(", args, ")"]
176 where args :: T.Text
177 args = T.intercalate "," $ map (compileJS' 0) rhs
179compileJS' indent (JSNew name args) =
180 "new "
181 `T.append` T.pack name
182 `T.append` "("
183 `T.append` T.intercalate "," (map (compileJS' 0) args)
184 `T.append` ")"
186compileJS' indent (JSError exc) =
187 "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"
189compileJS' indent (JSBinOp op lhs rhs) =
190 compileJS' indent lhs
191 `T.append` " "
192 `T.append` T.pack op
193 `T.append` " "
194 `T.append` compileJS' indent rhs
196compileJS' indent (JSPreOp op val) =
197 T.pack op `T.append` "(" `T.append` compileJS' indent val `T.append` ")"
199compileJS' indent (JSProj obj field)
200 | JSFunction {} <- obj =
201 T.concat ["(", compileJS' indent obj, ").", T.pack field]
202 | JSAssign {} <- obj =
203 T.concat ["(", compileJS' indent obj, ").", T.pack field]
204 | otherwise =
205 compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)
207compileJS' indent JSNull =
208 "null"
210compileJS' indent JSUndefined =
211 "undefined"
213compileJS' indent JSThis =
214 "this"
216compileJS' indent JSTrue =
217 "true"
219compileJS' indent JSFalse =
220 "false"
222compileJS' indent (JSArray elems) =
223 "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"
225compileJS' indent (JSString str) =
226 "\"" `T.append` T.pack str `T.append` "\""
228compileJS' indent (JSNum num)
229 | JSInt i <- num = T.pack (show i)
230 | JSFloat f <- num = T.pack (show f)
231 | JSInteger JSBigZero <- num = T.pack "i$ZERO"
232 | JSInteger JSBigOne <- num = T.pack "i$ONE"
233 | JSInteger (JSBigInt i) <- num = T.pack (show i)
234 | JSInteger (JSBigIntExpr e) <- num =
235 "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"
237compileJS' indent (JSAssign lhs rhs) =
238 compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs
240compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
241 "var "
242 `T.append` T.pack name
243 `T.append` " = "
244 `T.append` compileJS' 0 val
245 `T.append` ";\n"
247compileJS' indent (JSAlloc name val) =
248 "var "
249 `T.append` T.pack name
250 `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val
252compileJS' indent (JSIndex lhs rhs) =
253 compileJS' indent lhs
254 `T.append` "["
255 `T.append` compileJS' indent rhs
256 `T.append` "]"
258compileJS' indent (JSCond branches) =
259 T.intercalate " else " $ map createIfBlock branches
260 where
261 createIfBlock (JSNoop, e@(JSSeq _)) =
262 "{\n"
263 `T.append` compileJS' (indent + 2) e
264 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
265 createIfBlock (JSNoop, e) =
266 "{\n"
267 `T.append` compileJS' (indent + 2) e
268 `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"
269 createIfBlock (cond, e@(JSSeq _)) =
270 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
271 `T.append` compileJS' (indent + 2) e
272 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
273 createIfBlock (cond, e) =
274 "if (" `T.append` compileJS' indent cond `T.append`") {\n"
275 `T.append` T.replicate (indent + 2) " "
276 `T.append` compileJS' (indent + 2) e
277 `T.append` ";\n"
278 `T.append` T.replicate indent " "
279 `T.append` "}"
281compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
282 let (h,t) = splitAt 1 seq in
283 (T.concat (map (compileJS' indent) h) `T.append` ";\n")
284 `T.append` (
285 T.intercalate ";\n" $ map (
286 (T.replicate indent " " `T.append`) . compileJS' indent
287 ) t
288 )
290compileJS' indent (JSSwitch val branches def) =
291 "switch(" `T.append` compileJS' indent val `T.append` "){\n"
292 `T.append` T.concat (map mkBranch branches)
293 `T.append` mkDefault def
294 `T.append` T.replicate indent " " `T.append` "}"
295 where
296 mkBranch :: (JS, JS) -> T.Text
297 mkBranch (tag, code) =
298 T.replicate (indent + 2) " "
299 `T.append` "case "
300 `T.append` compileJS' indent tag
301 `T.append` ":\n"
302 `T.append` compileJS' (indent + 4) code
303 `T.append` "\n"
304 `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")
306 mkDefault :: Maybe JS -> T.Text
307 mkDefault Nothing = ""
308 mkDefault (Just def) =
309 T.replicate (indent + 2) " " `T.append` "default:\n"
310 `T.append` compileJS' (indent + 4)def
311 `T.append` "\n"
314compileJS' indent (JSTernary cond true false) =
315 let c = compileJS' indent cond
316 t = compileJS' indent true
317 f = compileJS' indent false in
318 "("
319 `T.append` c
320 `T.append` ")?("
321 `T.append` t
322 `T.append` "):("
323 `T.append` f
324 `T.append` ")"
326compileJS' indent (JSParens js) =
327 "(" `T.append` compileJS' indent js `T.append` ")"
329compileJS' indent (JSWhile cond body) =
330 "while (" `T.append` compileJS' indent cond `T.append` ") {\n"
331 `T.append` compileJS' (indent + 2) body
332 `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
334compileJS' indent (JSWord word)
335 | JSWord8 b <- word =
336 "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"
337 | JSWord16 b <- word =
338 "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"
339 | JSWord32 b <- word =
340 "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"
341 | JSWord64 b <- word =
342 "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"
344jsInstanceOf :: JS -> String -> JS
345jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
347jsOr :: JS -> JS -> JS
348jsOr lhs rhs = JSBinOp "||" lhs rhs
350jsAnd :: JS -> JS -> JS
351jsAnd lhs rhs = JSBinOp "&&" lhs rhs
353jsMeth :: JS -> String -> [JS] -> JS
354jsMeth obj meth args = JSApp (JSProj obj meth) args
356jsCall :: String -> [JS] -> JS
357jsCall fun args = JSApp (JSIdent fun) args
359jsTypeOf :: JS -> JS
360jsTypeOf js = JSPreOp "typeof " js
362jsEq :: JS -> JS -> JS
363jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
364jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
365jsEq lhs rhs = JSBinOp "==" lhs rhs
367jsNotEq :: JS -> JS -> JS
368jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
370jsIsNumber :: JS -> JS
371jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
373jsIsNull :: JS -> JS
374jsIsNull js = JSBinOp "==" js JSNull
376jsBigInt :: JS -> JS
377jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
378jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
379jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
381jsUnPackBits :: JS -> JS
382jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
384jsPackUBits8 :: JS -> JS
385jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
387jsPackUBits16 :: JS -> JS
388jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
390jsPackUBits32 :: JS -> JS
391jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
393jsPackSBits8 :: JS -> JS
394jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
396jsPackSBits16 :: JS -> JS
397jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
399jsPackSBits32 :: JS -> JS
400jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]