git.iko.soy/Idris-dev
on master help sign in
Merge pull request #1387 from raichoo/javascript
82753c9raichoo
idris.cabal+1
compare with master
unifiedsplit
@@ -599,6 +599,7 @@ Library
599 , IRTS.CodegenCommon
599 , IRTS.CodegenCommon
600 , IRTS.CodegenJava
600 , IRTS.CodegenJava
601 , IRTS.CodegenJavaScript
601 , IRTS.CodegenJavaScript
602+ , IRTS.JavaScript.AST
602 , IRTS.Compiler
603 , IRTS.Compiler
603 , IRTS.Defunctionalise
604 , IRTS.Defunctionalise
604 , IRTS.DumpBC
605 , IRTS.DumpBC
src/IRTS/CodegenJavaScript.hs+2−342
@@ -2,6 +2,8 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
3module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
4
4
5+import IRTS.JavaScript.AST
6+
5import Idris.AbsSyntax hiding (TypeCase)
7import Idris.AbsSyntax hiding (TypeCase)
6import IRTS.Bytecode
8import IRTS.Bytecode
7import IRTS.Lang
9import IRTS.Lang
@@ -82,290 +84,6 @@ initCompileInfo bc =
82data JSTarget = Node | JavaScript deriving Eq
84data JSTarget = Node | JavaScript deriving Eq
83
85
84
86
85−data JSType = JSIntTy
86− | JSStringTy
87− | JSIntegerTy
88− | JSFloatTy
89− | JSCharTy
90− | JSPtrTy
91− | JSForgotTy
92− deriving Eq
93−
94−
95−data JSInteger = JSBigZero
96− | JSBigOne
97− | JSBigInt Integer
98− | JSBigIntExpr JS
99− deriving Eq
100−
101−
102−data JSNum = JSInt Int
103− | JSFloat Double
104− | JSInteger JSInteger
105− deriving Eq
106−
107−
108−data JSWord = JSWord8 Word8
109− | JSWord16 Word16
110− | JSWord32 Word32
111− | JSWord64 Word64
112− deriving Eq
113−
114−
115−data JSAnnotation = JSConstructor deriving Eq
116−
117−
118−instance Show JSAnnotation where
119− show JSConstructor = "constructor"
120−
121−
122−data JS = JSRaw String
123− | JSIdent String
124− | JSFunction [String] JS
125− | JSType JSType
126− | JSSeq [JS]
127− | JSReturn JS
128− | JSApp JS [JS]
129− | JSNew String [JS]
130− | JSError String
131− | JSBinOp String JS JS
132− | JSPreOp String JS
133− | JSPostOp String JS
134− | JSProj JS String
135− | JSNull
136− | JSUndefined
137− | JSThis
138− | JSTrue
139− | JSFalse
140− | JSArray [JS]
141− | JSString String
142− | JSNum JSNum
143− | JSWord JSWord
144− | JSAssign JS JS
145− | JSAlloc String (Maybe JS)
146− | JSIndex JS JS
147− | JSSwitch JS [(JS, JS)] (Maybe JS)
148− | JSCond [(JS, JS)]
149− | JSTernary JS JS JS
150− | JSParens JS
151− | JSWhile JS JS
152− | JSFFI String [JS]
153− | JSAnnotation JSAnnotation JS
154− | JSNoop
155− deriving Eq
156−
157−
158−data FFI = FFICode Char | FFIArg Int | FFIError String
159−
160−ffi :: String -> [String] -> T.Text
161−ffi code args = let parsed = ffiParse code in
162− case ffiError parsed of
163− Just err -> error err
164− Nothing -> renderFFI parsed args
165− where
166− ffiParse :: String -> [FFI]
167− ffiParse "" = []
168− ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
169− ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
170− ffiParse ('%':s:ss)
171− | isDigit s =
172− FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
173− | otherwise =
174− [FFIError "FFI - Invalid positional argument"]
175− ffiParse (s:ss) = FFICode s : ffiParse ss
176−
177−
178− ffiError :: [FFI] -> Maybe String
179− ffiError [] = Nothing
180− ffiError ((FFIError s):xs) = Just s
181− ffiError (x:xs) = ffiError xs
182−
183−
184− renderFFI :: [FFI] -> [String] -> T.Text
185− renderFFI [] _ = ""
186− renderFFI (FFICode c : fs) args = c `T.cons` renderFFI fs args
187− renderFFI (FFIArg i : fs) args
188− | i < length args && i >= 0 = T.pack (args !! i) `T.append` renderFFI fs args
189− | otherwise = error "FFI - Argument index out of bounds"
190−
191−compileJS :: JS -> T.Text
192−compileJS = compileJS' 0
193−
194−compileJS' :: Int -> JS -> T.Text
195−compileJS' indent JSNoop = ""
196−
197−compileJS' indent (JSAnnotation annotation js) =
198− "/** @" `T.append` T.pack (show annotation) `T.append` " */\n" `T.append` compileJS' indent js
199−
200−compileJS' indent (JSFFI raw args) =
201− ffi raw (map (T.unpack . compileJS' indent) args)
202−
203−compileJS' indent (JSRaw code) =
204− T.pack code
205−
206−compileJS' indent (JSIdent ident) =
207− T.pack ident
208−
209−compileJS' indent (JSFunction args body) =
210− T.replicate indent " " `T.append` "function("
211− `T.append` T.intercalate "," (map T.pack args)
212− `T.append` "){\n"
213− `T.append` compileJS' (indent + 2) body
214− `T.append` "\n}\n"
215−
216−compileJS' indent (JSType ty)
217− | JSIntTy <- ty = "i$Int"
218− | JSStringTy <- ty = "i$String"
219− | JSIntegerTy <- ty = "i$Integer"
220− | JSFloatTy <- ty = "i$Float"
221− | JSCharTy <- ty = "i$Char"
222− | JSPtrTy <- ty = "i$Ptr"
223− | JSForgotTy <- ty = "i$Forgot"
224−
225−compileJS' indent (JSSeq seq) =
226− T.intercalate ";\n" (
227− map (
228− (T.replicate indent " " `T.append`) . (compileJS' indent)
229− ) $ filter (/= JSNoop) seq
230− ) `T.append` ";"
231−
232−compileJS' indent (JSReturn val) =
233− "return " `T.append` compileJS' indent val
234−
235−compileJS' indent (JSApp lhs rhs)
236− | JSFunction {} <- lhs =
237− T.concat ["(", compileJS' indent lhs, ")(", args, ")"]
238− | otherwise =
239− T.concat [compileJS' indent lhs, "(", args, ")"]
240− where args :: T.Text
241− args = T.intercalate "," $ map (compileJS' 0) rhs
242−
243−compileJS' indent (JSNew name args) =
244− "new " `T.append` T.pack name `T.append` "(" `T.append` T.intercalate "," (map (compileJS' 0) args) `T.append` ")"
245−
246−compileJS' indent (JSError exc) =
247− "throw new Error(\"" `T.append` T.pack exc `T.append` "\")"
248−
249−compileJS' indent (JSBinOp op lhs rhs) =
250− compileJS' indent lhs `T.append` " " `T.append` T.pack op `T.append` " " `T.append` compileJS' indent rhs
251−
252−compileJS' indent (JSPreOp op val) =
253− T.pack op `T.append` compileJS' indent val
254−
255−compileJS' indent (JSProj obj field)
256− | JSFunction {} <- obj =
257− T.concat ["(", compileJS' indent obj, ").", T.pack field]
258− | JSAssign {} <- obj =
259− T.concat ["(", compileJS' indent obj, ").", T.pack field]
260− | otherwise =
261− compileJS' indent obj `T.append` ('.' `T.cons` T.pack field)
262−
263−compileJS' indent JSNull =
264− "null"
265−
266−compileJS' indent JSUndefined =
267− "undefined"
268−
269−compileJS' indent JSThis =
270− "this"
271−
272−compileJS' indent JSTrue =
273− "true"
274−
275−compileJS' indent JSFalse =
276− "false"
277−
278−compileJS' indent (JSArray elems) =
279− "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"
280−
281−compileJS' indent (JSString str) =
282− "\"" `T.append` T.pack str `T.append` "\""
283−
284−compileJS' indent (JSNum num)
285− | JSInt i <- num = T.pack (show i)
286− | JSFloat f <- num = T.pack (show f)
287− | JSInteger JSBigZero <- num = T.pack "i$ZERO"
288− | JSInteger JSBigOne <- num = T.pack "i$ONE"
289− | JSInteger (JSBigInt i) <- num = T.pack (show i)
290− | JSInteger (JSBigIntExpr e) <- num = "i$bigInt(" `T.append` compileJS' indent e `T.append` ")"
291−
292−compileJS' indent (JSAssign lhs rhs) =
293− compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs
294−
295−compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
296− "var " `T.append` T.pack name `T.append` " = " `T.append` compileJS' 0 val `T.append` ";\n"
297−
298−compileJS' indent (JSAlloc name val) =
299− "var " `T.append` T.pack name `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val
300−
301−compileJS' indent (JSIndex lhs rhs) =
302− compileJS' indent lhs `T.append` "[" `T.append` compileJS' indent rhs `T.append` "]"
303−
304−compileJS' indent (JSCond branches) =
305− T.intercalate " else " $ map createIfBlock branches
306− where
307− createIfBlock (JSNoop, e@(JSSeq _)) =
308− "{\n"
309− `T.append` compileJS' (indent + 2) e
310− `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
311− createIfBlock (JSNoop, e) =
312− "{\n"
313− `T.append` compileJS' (indent + 2) e
314− `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"
315− createIfBlock (cond, e@(JSSeq _)) =
316− "if (" `T.append` compileJS' indent cond `T.append`") {\n"
317− `T.append` compileJS' (indent + 2) e
318− `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
319− createIfBlock (cond, e) =
320− "if (" `T.append` compileJS' indent cond `T.append`") {\n"
321− `T.append` T.replicate (indent + 2) " " `T.append` compileJS' (indent + 2) e
322− `T.append` ";\n" `T.append` T.replicate indent " " `T.append` "}"
323−
324−compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
325− let (h,t) = splitAt 1 seq in
326− (T.concat (map (compileJS' indent) h) `T.append` ";\n")
327− `T.append` (T.intercalate ";\n" $ map ((T.replicate indent " " `T.append`) . compileJS' indent) t)
328−
329−compileJS' indent (JSSwitch val branches def) =
330− "switch(" `T.append` compileJS' indent val `T.append` "){\n"
331− `T.append` T.concat (map mkBranch branches)
332− `T.append` mkDefault def
333− `T.append` T.replicate indent " " `T.append` "}"
334− where
335− mkBranch :: (JS, JS) -> T.Text
336− mkBranch (tag, code) =
337− T.replicate (indent + 2) " " `T.append` "case " `T.append` compileJS' indent tag `T.append` ":\n"
338− `T.append` compileJS' (indent + 4) code
339− `T.append` "\n" `T.append` (T.replicate (indent + 4) " " `T.append` "break;\n")
340−
341− mkDefault :: Maybe JS -> T.Text
342− mkDefault Nothing = ""
343− mkDefault (Just def) =
344− T.replicate (indent + 2) " " `T.append` "default:\n"
345− `T.append` compileJS' (indent + 4)def
346− `T.append` "\n"
347−
348−
349−compileJS' indent (JSTernary cond true false) =
350− let c = compileJS' indent cond
351− t = compileJS' indent true
352− f = compileJS' indent false in
353− "(" `T.append` c `T.append` ")?(" `T.append` t `T.append` "):(" `T.append` f `T.append` ")"
354−
355−compileJS' indent (JSParens js) =
356− "(" `T.append` compileJS' indent js `T.append` ")"
357−
358−compileJS' indent (JSWhile cond body) =
359− "while (" `T.append` compileJS' indent cond `T.append` ") {\n"
360− `T.append` compileJS' (indent + 2) body
361− `T.append` "\n" `T.append` T.replicate indent " " `T.append` "}"
362−
363−compileJS' indent (JSWord word)
364− | JSWord8 b <- word = "new Uint8Array([" `T.append` T.pack (show b) `T.append` "])"
365− | JSWord16 b <- word = "new Uint16Array([" `T.append` T.pack (show b) `T.append` "])"
366− | JSWord32 b <- word = "new Uint32Array([" `T.append` T.pack (show b) `T.append` "])"
367− | JSWord64 b <- word = "i$bigInt(\"" `T.append` T.pack (show b) `T.append` "\")"
368−
369codegenJavaScript :: CodeGenerator
87codegenJavaScript :: CodeGenerator
370codegenJavaScript ci =
88codegenJavaScript ci =
371 codegenJS_all JavaScript (simpleDecls ci)
89 codegenJS_all JavaScript (simpleDecls ci)
@@ -893,64 +611,6 @@ jsMKCON info r t rs =
893 ]
611 ]
894 )
612 )
895
613
896−jsInstanceOf :: JS -> String -> JS
897−jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
898−
899−jsOr :: JS -> JS -> JS
900−jsOr lhs rhs = JSBinOp "||" lhs rhs
901−
902−jsAnd :: JS -> JS -> JS
903−jsAnd lhs rhs = JSBinOp "&&" lhs rhs
904−
905−jsMeth :: JS -> String -> [JS] -> JS
906−jsMeth obj meth args = JSApp (JSProj obj meth) args
907−
908−jsCall :: String -> [JS] -> JS
909−jsCall fun args = JSApp (JSIdent fun) args
910−
911−jsTypeOf :: JS -> JS
912−jsTypeOf js = JSPreOp "typeof " js
913−
914−jsEq :: JS -> JS -> JS
915−jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
916−jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
917−jsEq lhs rhs = JSBinOp "==" lhs rhs
918−
919−jsNotEq :: JS -> JS -> JS
920−jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
921−
922−jsIsNumber :: JS -> JS
923−jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
924−
925−jsIsNull :: JS -> JS
926−jsIsNull js = JSBinOp "==" js JSNull
927−
928−jsBigInt :: JS -> JS
929−jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
930−jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
931−jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
932−
933−jsUnPackBits :: JS -> JS
934−jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
935−
936−jsPackUBits8 :: JS -> JS
937−jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
938−
939−jsPackUBits16 :: JS -> JS
940−jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
941−
942−jsPackUBits32 :: JS -> JS
943−jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
944−
945−jsPackSBits8 :: JS -> JS
946−jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
947−
948−jsPackSBits16 :: JS -> JS
949−jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
950−
951−jsPackSBits32 :: JS -> JS
952−jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
953−
954jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
614jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
955jsCASE info safe reg cases def =
615jsCASE info safe reg cases def =
956 JSSwitch (tag safe $ translateReg reg) (
616 JSSwitch (tag safe $ translateReg reg) (
src/IRTS/JavaScript/AST.hsnew file+397
@@ -0,0 +1,397 @@
1+{-# LANGUAGE PatternGuards #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module IRTS.JavaScript.AST where
4+
5+import Data.Word
6+import Data.Char (isDigit)
7+
8+import qualified Data.Text as T
9+
10+data JSType = JSIntTy
11+ | JSStringTy
12+ | JSIntegerTy
13+ | JSFloatTy
14+ | JSCharTy
15+ | JSPtrTy
16+ | JSForgotTy
17+ deriving Eq
18+
19+
20+data JSInteger = JSBigZero
21+ | JSBigOne
22+ | JSBigInt Integer
23+ | JSBigIntExpr JS
24+ deriving Eq
25+
26+
27+data JSNum = JSInt Int
28+ | JSFloat Double
29+ | JSInteger JSInteger
30+ deriving Eq
31+
32+
33+data JSWord = JSWord8 Word8
34+ | JSWord16 Word16
35+ | JSWord32 Word32
36+ | JSWord64 Word64
37+ deriving Eq
38+
39+
40+data JSAnnotation = JSConstructor deriving Eq
41+
42+
43+instance Show JSAnnotation where
44+ show JSConstructor = "constructor"
45+
46+
47+data 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
81+
82+
83+data FFI = FFICode Char | FFIArg Int | FFIError String
84+
85+ffi :: String -> [String] -> T.Text
86+ffi 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
103+
104+
105+ ffiError :: [FFI] -> Maybe String
106+ ffiError [] = Nothing
107+ ffiError ((FFIError s):xs) = Just s
108+ ffiError (x:xs) = ffiError xs
109+
110+
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"
119+
120+compileJS :: JS -> T.Text
121+compileJS = compileJS' 0
122+
123+compileJS' :: Int -> JS -> T.Text
124+compileJS' indent JSNoop = ""
125+
126+compileJS' indent (JSAnnotation annotation js) =
127+ "/** @"
128+ `T.append` T.pack (show annotation)
129+ `T.append` " */\n"
130+ `T.append` compileJS' indent js
131+
132+compileJS' indent (JSFFI raw args) =
133+ ffi raw (map (T.unpack . compileJS' indent) args)
134+
135+compileJS' indent (JSRaw code) =
136+ T.pack code
137+
138+compileJS' indent (JSIdent ident) =
139+ T.pack ident
140+
141+compileJS' 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"
147+
148+compileJS' 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"
156+
157+compileJS' indent (JSSeq seq) =
158+ T.intercalate ";\n" (
159+ map (
160+ (T.replicate indent " " `T.append`) . (compileJS' indent)
161+ ) $ filter (/= JSNoop) seq
162+ ) `T.append` ";"
163+
164+compileJS' indent (JSReturn val) =
165+ "return " `T.append` compileJS' indent val
166+
167+compileJS' 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
174+
175+compileJS' 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` ")"
181+
182+compileJS' indent (JSError exc) =
183+ "(function(){throw new Error(\"" `T.append` T.pack exc `T.append` "\")})()"
184+
185+compileJS' 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
191+
192+compileJS' indent (JSPreOp op val) =
193+ T.pack op `T.append` compileJS' indent val
194+
195+compileJS' 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)
202+
203+compileJS' indent JSNull =
204+ "null"
205+
206+compileJS' indent JSUndefined =
207+ "undefined"
208+
209+compileJS' indent JSThis =
210+ "this"
211+
212+compileJS' indent JSTrue =
213+ "true"
214+
215+compileJS' indent JSFalse =
216+ "false"
217+
218+compileJS' indent (JSArray elems) =
219+ "[" `T.append` T.intercalate "," (map (compileJS' 0) elems) `T.append` "]"
220+
221+compileJS' indent (JSString str) =
222+ "\"" `T.append` T.pack str `T.append` "\""
223+
224+compileJS' 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` ")"
232+
233+compileJS' indent (JSAssign lhs rhs) =
234+ compileJS' indent lhs `T.append` " = " `T.append` compileJS' indent rhs
235+
236+compileJS' 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"
242+
243+compileJS' indent (JSAlloc name val) =
244+ "var "
245+ `T.append` T.pack name
246+ `T.append` maybe "" ((" = " `T.append`) . compileJS' indent) val
247+
248+compileJS' indent (JSIndex lhs rhs) =
249+ compileJS' indent lhs
250+ `T.append` "["
251+ `T.append` compileJS' indent rhs
252+ `T.append` "]"
253+
254+compileJS' 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` "}"
276+
277+compileJS' 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+ )
285+
286+compileJS' 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")
301+
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"
308+
309+
310+compileJS' 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` ")"
321+
322+compileJS' indent (JSParens js) =
323+ "(" `T.append` compileJS' indent js `T.append` ")"
324+
325+compileJS' 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` "}"
329+
330+compileJS' 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` "\")"
339+
340+jsInstanceOf :: JS -> String -> JS
341+jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
342+
343+jsOr :: JS -> JS -> JS
344+jsOr lhs rhs = JSBinOp "||" lhs rhs
345+
346+jsAnd :: JS -> JS -> JS
347+jsAnd lhs rhs = JSBinOp "&&" lhs rhs
348+
349+jsMeth :: JS -> String -> [JS] -> JS
350+jsMeth obj meth args = JSApp (JSProj obj meth) args
351+
352+jsCall :: String -> [JS] -> JS
353+jsCall fun args = JSApp (JSIdent fun) args
354+
355+jsTypeOf :: JS -> JS
356+jsTypeOf js = JSPreOp "typeof " js
357+
358+jsEq :: JS -> JS -> JS
359+jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
360+jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
361+jsEq lhs rhs = JSBinOp "==" lhs rhs
362+
363+jsNotEq :: JS -> JS -> JS
364+jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
365+
366+jsIsNumber :: JS -> JS
367+jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
368+
369+jsIsNull :: JS -> JS
370+jsIsNull js = JSBinOp "==" js JSNull
371+
372+jsBigInt :: JS -> JS
373+jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
374+jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
375+jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
376+
377+jsUnPackBits :: JS -> JS
378+jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
379+
380+jsPackUBits8 :: JS -> JS
381+jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
382+
383+jsPackUBits16 :: JS -> JS
384+jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
385+
386+jsPackUBits32 :: JS -> JS
387+jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
388+
389+jsPackSBits8 :: JS -> JS
390+jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
391+
392+jsPackSBits16 :: JS -> JS
393+jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
394+
395+jsPackSBits32 :: JS -> JS
396+jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
397+