git.iko.soy/Idris-dev
on master help sign in
Merge pull request #444 from raichoo/javascript
9749544Edwin Brady
js/Runtime-common.js+3−2
compare with master
unifiedsplit
@@ -14,6 +14,7 @@ var __IDRRT__Forgot = new __IDRRT__Type('Forgot');
14
14
15/** @constructor */
15/** @constructor */
16var __IDRRT__Tailcall = function(f) { this.f = f };
16var __IDRRT__Tailcall = function(f) { this.f = f };
17+
17var __IDRRT__ffiWrap = function(fid) {
18var __IDRRT__ffiWrap = function(fid) {
18 return function(arg) {
19 return function(arg) {
19 return __IDRRT__tailcall(function(){
20 return __IDRRT__tailcall(function(){
@@ -23,8 +24,8 @@ var __IDRRT__ffiWrap = function(fid) {
23};
24};
24
25
25/** @constructor */
26/** @constructor */
26−var __IDRRT__Con = function(i,vars) {
27+var __IDRRT__Con = function(tag,vars) {
27− this.i = i;
28+ this.tag = tag;
28 this.vars = vars;
29 this.vars = vars;
29};
30};
30
31
src/IRTS/CodegenJavaScript.hs+368−214
@@ -2,7 +2,7 @@
2
2
3module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where
3module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where
4
4
5−import Idris.AbsSyntax
5+import Idris.AbsSyntax hiding (TypeCase)
6import IRTS.Bytecode
6import IRTS.Bytecode
7import IRTS.Lang
7import IRTS.Lang
8import IRTS.Simplified
8import IRTS.Simplified
@@ -14,16 +14,187 @@ import Util.System
14import Control.Arrow
14import Control.Arrow
15import Data.Char
15import Data.Char
16import Data.List
16import Data.List
17−import qualified Data.Map as Map
18import System.IO
17import System.IO
19import System.Directory
18import System.Directory
20
19
21idrNamespace :: String
20idrNamespace :: String
22−idrNamespace = "__IDR__"
21+idrNamespace = "__IDR__"
23idrRTNamespace = "__IDRRT__"
22idrRTNamespace = "__IDRRT__"
24
23
25data JSTarget = Node | JavaScript deriving Eq
24data JSTarget = Node | JavaScript deriving Eq
26
25
26+data JSType = JSIntTy
27+ | JSStringTy
28+ | JSIntegerTy
29+ | JSFloatTy
30+ | JSCharTy
31+ | JSPtrTy
32+ | JSForgotTy
33+ deriving Eq
34+
35+data JSNum = JSInt Int
36+ | JSFloat Double
37+ | JSInteger Integer
38+
39+data JS = JSRaw String
40+ | JSFunction [String] JS
41+ | JSType JSType
42+ | JSSeq [JS]
43+ | JSReturn JS
44+ | JSApp JS [JS]
45+ | JSNew String [JS]
46+ | JSError String
47+ | JSOp String JS JS
48+ | JSProj JS String
49+ | JSVar LVar
50+ | JSNull
51+ | JSThis
52+ | JSTrue
53+ | JSArray [JS]
54+ | JSObject [(String, JS)]
55+ | JSString String
56+ | JSNum JSNum
57+ | JSAssign JS JS
58+ | JSAlloc String (Maybe JS)
59+ | JSIndex JS JS
60+ | JSCond [(JS, JS)]
61+
62+compileJS :: JS -> String
63+compileJS (JSRaw code) =
64+ code
65+
66+compileJS (JSFunction args body) =
67+ "function("
68+ ++ intercalate "," args
69+ ++ "){\n"
70+ ++ compileJS body
71+ ++ "\n}"
72+
73+compileJS (JSType ty)
74+ | JSIntTy <- ty = idrRTNamespace ++ "Int"
75+ | JSStringTy <- ty = idrRTNamespace ++ "String"
76+ | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
77+ | JSFloatTy <- ty = idrRTNamespace ++ "Float"
78+ | JSCharTy <- ty = idrRTNamespace ++ "Char"
79+ | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
80+ | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
81+
82+compileJS (JSSeq seq) =
83+ intercalate ";\n" (map compileJS seq)
84+
85+compileJS (JSReturn val) =
86+ "return " ++ compileJS val
87+
88+compileJS (JSApp lhs rhs)
89+ | JSFunction {} <- lhs =
90+ concat ["(", compileJS lhs, ")(", args, ")"]
91+ | otherwise =
92+ concat [compileJS lhs, "(", args, ")"]
93+ where args :: String
94+ args = intercalate "," $ map compileJS rhs
95+
96+compileJS (JSNew name args) =
97+ "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
98+
99+compileJS (JSError exc) =
100+ "(function(){throw '" ++ exc ++ "';})()"
101+
102+compileJS (JSOp op lhs rhs) =
103+ compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
104+
105+compileJS (JSProj obj field)
106+ | JSFunction {} <- obj =
107+ concat ["(", compileJS obj, ").", field]
108+ | otherwise =
109+ compileJS obj ++ '.' : field
110+
111+compileJS (JSVar var) =
112+ translateVariableName var
113+
114+compileJS JSNull =
115+ "null"
116+
117+compileJS JSThis =
118+ "this"
119+
120+compileJS JSTrue =
121+ "true"
122+
123+compileJS (JSArray elems) =
124+ "[" ++ intercalate "," (map compileJS elems) ++ "]"
125+
126+compileJS (JSObject fields) =
127+ "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
128+ where
129+ compileField :: (String, JS) -> String
130+ compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
131+
132+compileJS (JSString str) =
133+ show str
134+
135+compileJS (JSNum num)
136+ | JSInt i <- num = show i
137+ | JSFloat f <- num = show f
138+ | JSInteger i <- num = show i
139+
140+compileJS (JSAssign lhs rhs) =
141+ compileJS lhs ++ "=" ++ compileJS rhs
142+
143+compileJS (JSAlloc name val) =
144+ "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
145+
146+compileJS (JSIndex lhs rhs) =
147+ compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
148+
149+compileJS (JSCond branches) =
150+ intercalate " else " $ map createIfBlock branches
151+ where
152+ createIfBlock (cond, e) =
153+ "if (" ++ compileJS cond ++") {\n"
154+ ++ "return " ++ compileJS e
155+ ++ ";\n}"
156+
157+jsTailcall :: JS -> JS
158+jsTailcall call =
159+ jsCall (idrRTNamespace ++ "tailcall") [
160+ JSFunction [] (JSReturn call)
161+ ]
162+
163+jsCall :: String -> [JS] -> JS
164+jsCall fun = JSApp (JSRaw fun)
165+
166+jsMeth :: JS -> String -> [JS] -> JS
167+jsMeth obj meth =
168+ JSApp (JSProj obj meth)
169+
170+jsInstanceOf :: JS -> JS -> JS
171+jsInstanceOf = JSOp "instanceof"
172+
173+jsEq :: JS -> JS -> JS
174+jsEq = JSOp "=="
175+
176+jsAnd :: JS -> JS -> JS
177+jsAnd = JSOp "&&"
178+
179+jsType :: JS
180+jsType = JSRaw $ idrRTNamespace ++ "Type"
181+
182+jsCon :: JS
183+jsCon = JSRaw $ idrRTNamespace ++ "Con"
184+
185+jsTag :: JS -> JS
186+jsTag obj = (JSProj obj "tag")
187+
188+jsTypeTag :: JS -> JS
189+jsTypeTag obj = (JSProj obj "type")
190+
191+jsBigInt :: JS -> JS
192+jsBigInt val =
193+ JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]
194+
195+jsVar :: Int -> String
196+jsVar = ("__var_" ++) . show
197+
27codegenJavaScript
198codegenJavaScript
28 :: JSTarget
199 :: JSTarget
29 -> [(Name, SDecl)]
200 -> [(Name, SDecl)]
@@ -39,26 +210,29 @@ codegenJavaScript target definitions filename outputType = do
39 path <- getDataDir
210 path <- getDataDir
40 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
211 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
41 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
212 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
42− writeFile filename ( header
213+ writeFile filename $ intercalate "\n" $ [ header
43− ++ idrRuntime
214+ , idrRuntime
44− ++ tgtRuntime
215+ , tgtRuntime
45− ++ functions
216+ ] ++ functions ++ [mainLoop]
46− ++ mainLoop)
47
217
48 setPermissions filename (emptyPermissions { readable = True
218 setPermissions filename (emptyPermissions { readable = True
49 , executable = target == Node
219 , executable = target == Node
50 , writable = True
220 , writable = True
51 })
221 })
52 where
222 where
223+ def :: [(String, SDecl)]
53 def = map (first translateNamespace) definitions
224 def = map (first translateNamespace) definitions
54−
225+
55− functions = concatMap translateDeclaration def
226+ functions :: [String]
227+ functions = map (compileJS . translateDeclaration) def
56
228
57 mainLoop :: String
229 mainLoop :: String
58− mainLoop = intercalate "\n" [ "\nfunction main() {"
230+ mainLoop = compileJS $
59− , createTailcall "__IDR__runMain0()"
231+ JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
60− , "}\n\nmain();\n"
232+ jsTailcall $ jsCall "__IDR__runMain0" []
61− ]
233+ )
234+ , jsCall "main" []
235+ ]
62
236
63translateIdentifier :: String -> String
237translateIdentifier :: String -> String
64translateIdentifier =
238translateIdentifier =
@@ -99,14 +273,14 @@ translateIdentifier =
99 , "void"
273 , "void"
100 , "while"
274 , "while"
101 , "with"
275 , "with"
102−
276+
103 , "class"
277 , "class"
104 , "enum"
278 , "enum"
105 , "export"
279 , "export"
106 , "extends"
280 , "extends"
107 , "import"
281 , "import"
108 , "super"
282 , "super"
109−
283+
110 , "implements"
284 , "implements"
111 , "interface"
285 , "interface"
112 , "let"
286 , "let"
@@ -128,106 +302,102 @@ translateName (UN name) = translateIdentifier name
128translateName (NS name _) = translateName name
302translateName (NS name _) = translateName name
129translateName (MN i name) = translateIdentifier name ++ show i
303translateName (MN i name) = translateIdentifier name ++ show i
130
304
131−translateConstant :: Const -> String
305+translateConstant :: Const -> JS
132−translateConstant (I i) = show i
306+translateConstant (I i) = JSNum (JSInt i)
133−translateConstant (BI i) = idrRTNamespace ++ "bigInt('" ++ show i ++ "')"
307+translateConstant (Fl f) = JSNum (JSFloat f)
134−translateConstant (Fl f) = show f
308+translateConstant (Ch c) = JSString [c]
135−translateConstant (Ch c) = show c
309+translateConstant (Str s) = JSString s
136−translateConstant (Str s) = show s
310+translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
137−translateConstant (AType (ATInt ITNative)) = idrRTNamespace ++ "Int"
311+translateConstant StrType = JSType JSStringTy
138−translateConstant StrType = idrRTNamespace ++ "String"
312+translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
139−translateConstant (AType (ATInt ITBig)) = idrRTNamespace ++ "Integer"
313+translateConstant (AType ATFloat) = JSType JSFloatTy
140−translateConstant (AType ATFloat) = idrRTNamespace ++ "Float"
314+translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
141−translateConstant (AType (ATInt ITChar)) = idrRTNamespace ++ "Char"
315+translateConstant PtrType = JSType JSPtrTy
142−translateConstant PtrType = idrRTNamespace ++ "Ptr"
316+translateConstant Forgot = JSType JSForgotTy
143−translateConstant Forgot = idrRTNamespace ++ "Forgot"
317+translateConstant (BI i) = jsBigInt $ JSNum (JSInteger i)
144−translateConstant c =
318+translateConstant c =
145− "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
319+ JSError $ "Unimplemented Constant: " ++ show c
146−
320+
147−translateParameterlist =
321+translateDeclaration :: (String, SDecl) -> JS
148− map translateParameter
149− where translateParameter (MN i name) = translateIdentifier name ++ show i
150− translateParameter (UN name) = translateIdentifier name
151−
152−translateDeclaration :: (String, SDecl) -> String
153translateDeclaration (path, SFun name params stackSize body) =
322translateDeclaration (path, SFun name params stackSize body) =
154− "var " ++ path ++ translateName name
323+ JSAlloc (path ++ translateName name) $ Just $ JSFunction p (
155− ++ " = function("
324+ JSSeq $
156− ++ intercalate "," p
325+ zipWith assignVar [0..] p ++
157− ++ "){\n"
326+ map allocVar [numP .. (numP + stackSize - 1)] ++
158− ++ concatMap assignVar (zip [0..] p)
327+ [JSReturn $ translateExpression body]
159− ++ concatMap allocVar [numP..(numP+stackSize-1)]
328+ )
160− ++ "return "
329+ where
161− ++ translateExpression body
162− ++ ";\n};\n"
163− where
164 numP :: Int
330 numP :: Int
165 numP = length params
331 numP = length params
166
332
167− allocVar :: Int -> String
333+ allocVar :: Int -> JS
168− allocVar n = "var __var_" ++ show n ++ ";\n"
334+ allocVar n = JSAlloc (jsVar n) Nothing
169
335
170− assignVar :: (Int, String) -> String
336+ assignVar :: Int -> String -> JS
171− assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
337+ assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
172
338
173 p :: [String]
339 p :: [String]
174− p = translateParameterlist params
340+ p = map translateParameter params
341+ where
342+ translateParameter :: Name -> String
343+ translateParameter (MN i name) =
344+ translateIdentifier name ++ show i
345+ translateParameter (UN name) =
346+ translateIdentifier name
175
347
176translateVariableName :: LVar -> String
348translateVariableName :: LVar -> String
177translateVariableName (Loc i) =
349translateVariableName (Loc i) =
178− "__var_" ++ show i
350+ jsVar i
179
351
180−translateExpression :: SExp -> String
352+translateExpression :: SExp -> JS
181translateExpression (SLet name value body) =
353translateExpression (SLet name value body) =
182− "(function("
354+ JSApp (
183− ++ translateVariableName name
355+ JSFunction [translateVariableName name] (
184− ++ "){\nreturn "
356+ JSReturn $ translateExpression body
185− ++ translateExpression body
357+ )
186− ++ ";\n})("
358+ ) [translateExpression value]
187− ++ translateExpression value
188− ++ ")"
189
359
190translateExpression (SConst cst) =
360translateExpression (SConst cst) =
191 translateConstant cst
361 translateConstant cst
192
362
193translateExpression (SV var) =
363translateExpression (SV var) =
194− translateVariableName var
364+ JSVar var
195−
365+
196−translateExpression (SApp False name vars) =
366+translateExpression (SApp tc name vars)
197− createTailcall $ translateFunctionCall name vars
367+ | False <- tc =
198−
368+ jsTailcall $ translateFunctionCall name vars
199−translateExpression (SApp True name vars) =
369+ | True <- tc =
200− "new " ++ idrRTNamespace ++ "Tailcall("
370+ JSNew (idrRTNamespace ++ "Tailcall") [JSFunction [] (
201− ++ "function(){\n"
371+ JSReturn $ translateFunctionCall name vars
202− ++ "return " ++ translateFunctionCall name vars
372+ )]
203− ++ ";\n})"
373+ where
374+ translateFunctionCall name vars =
375+ jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
204
376
205translateExpression (SOp op vars)
377translateExpression (SOp op vars)
206− | LNoOp <- op = translateVariableName (last vars)
378+ | LNoOp <- op = JSVar (last vars)
207−
208− | (LZExt _ ITBig) <- op =
209− idrRTNamespace ++ "bigInt(" ++ translateVariableName (last vars) ++ ")"
210
379
380+ | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
211 | (LPlus (ATInt ITBig)) <- op
381 | (LPlus (ATInt ITBig)) <- op
212− , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
382+ , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
213 | (LMinus (ATInt ITBig)) <- op
383 | (LMinus (ATInt ITBig)) <- op
214− , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
384+ , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
215 | (LTimes (ATInt ITBig)) <- op
385 | (LTimes (ATInt ITBig)) <- op
216− , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
386+ , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
217 | (LSDiv (ATInt ITBig)) <- op
387 | (LSDiv (ATInt ITBig)) <- op
218− , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
388+ , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
219 | (LSRem (ATInt ITBig)) <- op
389 | (LSRem (ATInt ITBig)) <- op
220− , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
390+ , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
221 | (LEq (ATInt ITBig)) <- op
391 | (LEq (ATInt ITBig)) <- op
222− , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
392+ , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
223 | (LSLt (ATInt ITBig)) <- op
393 | (LSLt (ATInt ITBig)) <- op
224− , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
394+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
225 | (LSLe (ATInt ITBig)) <- op
395 | (LSLe (ATInt ITBig)) <- op
226− , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
396+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
227 | (LSGt (ATInt ITBig)) <- op
397 | (LSGt (ATInt ITBig)) <- op
228− , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
398+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
229 | (LSGe (ATInt ITBig)) <- op
399 | (LSGe (ATInt ITBig)) <- op
230− , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
400+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
231
401
232 | (LPlus ATFloat) <- op
402 | (LPlus ATFloat) <- op
233 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
403 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
@@ -279,7 +449,7 @@ translateExpression (SOp op vars)
279 | (LASHR _) <- op
449 | (LASHR _) <- op
280 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
450 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
281 | (LCompl _) <- op
451 | (LCompl _) <- op
282− , (arg:_) <- vars = '~' : translateVariableName arg
452+ , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
283
453
284 | LStrConcat <- op
454 | LStrConcat <- op
285 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
455 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
@@ -288,126 +458,122 @@ translateExpression (SOp op vars)
288 | LStrLt <- op
458 | LStrLt <- op
289 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
459 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
290 | LStrLen <- op
460 | LStrLen <- op
291− , (arg:_) <- vars = translateVariableName arg ++ ".length"
461+ , (arg:_) <- vars = JSProj (JSVar arg) "length"
292
462
293 | (LStrInt ITNative) <- op
463 | (LStrInt ITNative) <- op
294− , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
464+ , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
295 | (LIntStr ITNative) <- op
465 | (LIntStr ITNative) <- op
296− , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
466+ , (arg:_) <- vars = jsCall "String" [JSVar arg]
297 | (LSExt ITNative ITBig) <- op
467 | (LSExt ITNative ITBig) <- op
298− , (arg:_) <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")"
468+ , (arg:_) <- vars = jsBigInt $ JSVar arg
299 | (LTrunc ITBig ITNative) <- op
469 | (LTrunc ITBig ITNative) <- op
300− , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
470+ , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
301 | (LIntStr ITBig) <- op
471 | (LIntStr ITBig) <- op
302− , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
472+ , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
303 | (LStrInt ITBig) <- op
473 | (LStrInt ITBig) <- op
304− , (arg:_) <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")"
474+ , (arg:_) <- vars = jsBigInt $ JSVar arg
305 | LFloatStr <- op
475 | LFloatStr <- op
306− , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
476+ , (arg:_) <- vars = jsCall "String" [JSVar arg]
307 | LStrFloat <- op
477 | LStrFloat <- op
308− , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
478+ , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
309 | (LIntFloat ITNative) <- op
479 | (LIntFloat ITNative) <- op
310− , (arg:_) <- vars = translateVariableName arg
480+ , (arg:_) <- vars = JSVar arg
311 | (LFloatInt ITNative) <- op
481 | (LFloatInt ITNative) <- op
312− , (arg:_) <- vars = translateVariableName arg
482+ , (arg:_) <- vars = JSVar arg
313 | (LChInt ITNative) <- op
483 | (LChInt ITNative) <- op
314− , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
484+ , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
315 | (LIntCh ITNative) <- op
485 | (LIntCh ITNative) <- op
316− , (arg:_) <- vars =
486+ , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
317− "String.fromCharCode(" ++ translateVariableName arg ++ ")"
318
487
319 | LFExp <- op
488 | LFExp <- op
320− , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
489+ , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
321 | LFLog <- op
490 | LFLog <- op
322− , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
491+ , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
323 | LFSin <- op
492 | LFSin <- op
324− , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
493+ , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
325 | LFCos <- op
494 | LFCos <- op
326− , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
495+ , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
327 | LFTan <- op
496 | LFTan <- op
328− , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
497+ , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
329 | LFASin <- op
498 | LFASin <- op
330− , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
499+ , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
331 | LFACos <- op
500 | LFACos <- op
332− , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
501+ , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
333 | LFATan <- op
502 | LFATan <- op
334− , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
503+ , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
335 | LFSqrt <- op
504 | LFSqrt <- op
336− , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
505+ , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
337 | LFFloor <- op
506 | LFFloor <- op
338− , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
507+ , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
339 | LFCeil <- op
508 | LFCeil <- op
340− , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
509+ , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
341
510
342 | LStrCons <- op
511 | LStrCons <- op
343 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
512 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
344 | LStrHead <- op
513 | LStrHead <- op
345− , (arg:_) <- vars = translateVariableName arg ++ "[0]"
514+ , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
346 | LStrRev <- op
515 | LStrRev <- op
347− , (arg:_) <- vars = let v = translateVariableName arg in
516+ , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
348− v ++ ".split('').reverse().join('')"
349 | LStrIndex <- op
517 | LStrIndex <- op
350− , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
518+ , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
351− r = translateVariableName rhs in
352− l ++ "[" ++ r ++ "]"
353 | LStrTail <- op
519 | LStrTail <- op
354 , (arg:_) <- vars = let v = translateVariableName arg in
520 , (arg:_) <- vars = let v = translateVariableName arg in
355− v ++ ".substr(1," ++ v ++ ".length-1)"
521+ JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
356 where
522 where
357− translateBinaryOp :: String -> LVar -> LVar -> String
523+ translateBinaryOp :: String -> LVar -> LVar -> JS
358− translateBinaryOp f lhs rhs =
524+ translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
359− translateVariableName lhs
525+
360− ++ f
526+ invokeMeth :: LVar -> String -> [LVar] -> JS
361− ++ translateVariableName rhs
527+ invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
362
528
363translateExpression (SError msg) =
529translateExpression (SError msg) =
364− "(function(){throw \'" ++ msg ++ "\';})()"
530+ JSError msg
365
531
366translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
532translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
367− idrRTNamespace ++ "print(" ++ translateVariableName var ++ ")"
533+ jsCall (idrRTNamespace ++ "print") [JSVar var]
368
534
369translateExpression (SForeign _ _ fun args)
535translateExpression (SForeign _ _ fun args)
370 | "[]=" `isSuffixOf` fun
536 | "[]=" `isSuffixOf` fun
371 , (obj:idx:val:[]) <- args =
537 , (obj:idx:val:[]) <- args =
372− concat [object obj, index idx, assign val]
538+ JSRaw $ concat [object obj, index idx, assign val]
373
539
374 | "[]" `isSuffixOf` fun
540 | "[]" `isSuffixOf` fun
375 , (obj:idx:[]) <- args =
541 , (obj:idx:[]) <- args =
376− object obj ++ index idx
542+ JSRaw $ object obj ++ index idx
377
543
378 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
544 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
379 , (obj:val:[]) <- args =
545 , (obj:val:[]) <- args =
380− concat [object obj, '[' : name ++ "]", assign val]
546+ JSRaw $ concat [object obj, '[' : name ++ "]", assign val]
381
547
382 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
548 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
383 , (obj:[]) <- args =
549 , (obj:[]) <- args =
384− object obj ++ '[' : name ++ "]"
550+ JSRaw $ object obj ++ '[' : name ++ "]"
385
551
386 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
552 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
387 , (obj:val:[]) <- args =
553 , (obj:val:[]) <- args =
388− concat [object obj, field, assign val]
554+ JSRaw $ concat [object obj, field, assign val]
389
555
390 | "." `isPrefixOf` fun
556 | "." `isPrefixOf` fun
391 , (obj:[]) <- args =
557 , (obj:[]) <- args =
392− object obj ++ field
558+ JSRaw $ object obj ++ field
393
559
394 | "." `isPrefixOf` fun
560 | "." `isPrefixOf` fun
395 , (obj:[(FUnit, _)]) <- args =
561 , (obj:[(FUnit, _)]) <- args =
396− concat [object obj, method, "()"]
562+ JSRaw $ concat [object obj, method, "()"]
397−
563+
398 | "." `isPrefixOf` fun
564 | "." `isPrefixOf` fun
399 , (obj:as) <- args =
565 , (obj:as) <- args =
400− concat [object obj, method, arguments as]
566+ JSRaw $ concat [object obj, method, arguments as]
401
567
402 | "[]=" `isSuffixOf` fun
568 | "[]=" `isSuffixOf` fun
403 , (idx:val:[]) <- args =
569 , (idx:val:[]) <- args =
404− concat [array, index idx, assign val]
570+ JSRaw $ concat [array, index idx, assign val]
405
571
406 | "[]" `isSuffixOf` fun
572 | "[]" `isSuffixOf` fun
407 , (idx:[]) <- args =
573 , (idx:[]) <- args =
408− array ++ index idx
574+ JSRaw $ array ++ index idx
409
575
410− | otherwise = fun ++ arguments args
576+ | otherwise = JSRaw $ fun ++ arguments args
411 where
577 where
412 name = filter (`notElem` "[]=") fun
578 name = filter (`notElem` "[]=") fun
413 method = name
579 method = name
@@ -420,101 +586,89 @@ translateExpression (SForeign _ _ fun args)
420 '(' : intercalate "," (map generateWrapper as) ++ ")"
586 '(' : intercalate "," (map generateWrapper as) ++ ")"
421
587
422 generateWrapper (ffunc, name)
588 generateWrapper (ffunc, name)
423− | FFunction <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
589+ | FFunction <- ffunc =
424− | FFunctionIO <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
590+ idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
591+ | FFunctionIO <- ffunc =
592+ idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
425
593
426 generateWrapper (_, name) =
594 generateWrapper (_, name) =
427 translateVariableName name
595 translateVariableName name
428
596
429−translateExpression (SChkCase var cases) =
597+translateExpression patterncase
430− "(function(e){\n"
598+ | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
431− ++ intercalate " else " (map (translateCase "e") cases)
599+ | (SCase var cases) <- patterncase = caseHelper var cases "cse"
432− ++ "\n})("
600+ where
433− ++ translateVariableName var
601+ caseHelper var cases param =
434− ++ ")"
602+ JSApp (JSFunction [param] (
435−
603+ JSCond $ map ((expandCase param) . translateCase param) cases
436−translateExpression (SCase var cases) =
604+ )) [JSVar var]
437− "(function(e){\n"
605+
438− ++ intercalate " else " (map (translateCase "e") cases)
606+ expandCase :: String -> (Cond, JS) -> (JS, JS)
439− ++ "\n})("
607+ expandCase _ (RawCond cond, branch) = (cond, branch)
440− ++ translateVariableName var
608+ expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
441− ++ ")"
609+ expandCase var (CaseCond caseTy, branch)
610+ | ConCase tag <- caseTy =
611+ let checkCon = JSRaw var `jsInstanceOf` jsCon
612+ checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
613+ (checkCon `jsAnd` checkTag, branch)
614+
615+ | TypeCase ty <- caseTy =
616+ let checkTy = JSRaw var `jsInstanceOf` jsType
617+ checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in
618+ (checkTy `jsAnd` checkTag, branch)
442
619
443translateExpression (SCon i name vars) =
620translateExpression (SCon i name vars) =
444− concat [ "new " ++ idrRTNamespace ++ "Con("
621+ JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
445− , show i
622+ , JSArray $ map JSVar vars
446− , ",["
623+ ]
447− , intercalate "," $ map translateVariableName vars
448− , "])"
449− ]
450
624
451translateExpression (SUpdate var e) =
625translateExpression (SUpdate var e) =
452− translateVariableName var ++ " = " ++ translateExpression e
626+ JSAssign (JSVar var) (translateExpression e)
453
627
454translateExpression (SProj var i) =
628translateExpression (SProj var i) =
455− translateVariableName var ++ ".vars[" ++ show i ++"]"
629+ JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
456
630
457−translateExpression SNothing = "null"
631+translateExpression SNothing = JSNull
458
632
459translateExpression e =
633translateExpression e =
460− "(function(){throw 'Not yet implemented: "
634+ JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
461− ++ filter (/= '\'') (show e)
635+
462− ++ "';})()"
636+data CaseType = ConCase Int
637+ | TypeCase JSType
638+ | DefaultCase
639+ deriving Eq
640+
641+data Cond = CaseCond CaseType
642+ | RawCond JS
463
643
464−translateCase :: String -> SAlt -> String
644+translateCase :: String -> SAlt -> (Cond, JS)
465translateCase _ (SDefaultCase e) =
645translateCase _ (SDefaultCase e) =
466− createIfBlock "true" (translateExpression e)
646+ (CaseCond DefaultCase, translateExpression e)
467
647
468translateCase var (SConstCase ty e)
648translateCase var (SConstCase ty e)
469− | StrType <- ty = matchHelper "String"
649+ | StrType <- ty = matchHelper JSStringTy
470− | PtrType <- ty = matchHelper "Ptr"
650+ | PtrType <- ty = matchHelper JSPtrTy
471− | Forgot <- ty = matchHelper "Forgot"
651+ | Forgot <- ty = matchHelper JSForgotTy
472− | (AType ATFloat) <- ty = matchHelper "Float"
652+ | (AType ATFloat) <- ty = matchHelper JSFloatTy
473− | (AType (ATInt ITBig)) <- ty = matchHelper "Integer"
653+ | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
474− | (AType (ATInt ITNative)) <- ty = matchHelper "Int"
654+ | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
475− | (AType (ATInt ITChar)) <- ty = matchHelper "Char"
655+ | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
476 where
656 where
477− matchHelper tyName = translateTypeMatch var tyName e
657+ matchHelper :: JSType -> (Cond, JS)
658+ matchHelper ty = (CaseCond $ TypeCase ty, translateExpression e)
478
659
479translateCase var (SConstCase cst@(BI _) e) =
660translateCase var (SConstCase cst@(BI _) e) =
480− let cond = idrRTNamespace ++ "bigInt(" ++ var ++ ").equals(" ++ translateConstant cst ++ ")" in
661+ let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
481− createIfBlock cond (translateExpression e)
662+ (RawCond cond, translateExpression e)
482
663
483translateCase var (SConstCase cst e) =
664translateCase var (SConstCase cst e) =
484− let cond = var ++ " == " ++ translateConstant cst in
665+ let cond = JSRaw var `jsEq` translateConstant cst in
485− createIfBlock cond (translateExpression e)
666+ (RawCond cond, translateExpression e)
486−
667+
487−translateCase var (SConCase a i name vars e) =
668+translateCase var (SConCase a tag name vars e) =
488− let isCon = var ++ " instanceof " ++ idrRTNamespace ++ "Con"
669+ let params = map jsVar [a .. (a + length vars)] in
489− isI = show i ++ " == " ++ var ++ ".i"
670+ (CaseCond $ ConCase tag,
490− params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
671+ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
491− args = ".apply(this," ++ var ++ ".vars)"
672+ JSThis, JSProj (JSRaw var) "vars"
492− f b =
673+ ]
493− "(function("
674+ )
494− ++ params
495− ++ "){\nreturn " ++ b ++ "\n})" ++ args
496− cond = intercalate " && " [isCon, isI] in
497− createIfBlock cond $ f (translateExpression e)
498−
499−translateTypeMatch :: String -> String -> SExp -> String
500−translateTypeMatch var ty exp =
501− let e = translateExpression exp in
502− createIfBlock (var
503− ++ " instanceof " ++ idrRTNamespace ++ "Type && "
504− ++ var ++ ".type == '"++ ty ++"'") e
505−
506−
507−createIfBlock cond e =
508− "if (" ++ cond ++") {\n"
509− ++ "return " ++ e
510− ++ ";\n}"
511−
512−createTailcall call =
513− idrRTNamespace ++ "tailcall(function(){return " ++ call ++ "})"
514−
515−translateFunctionCall name vars =
516− translateNamespace name
517− ++ translateName name
518− ++ "("
519− ++ intercalate "," (map translateVariableName vars)
520− ++ ")"