@@ -2,7 +2,7 @@
22
33module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where
44
5−import Idris.AbsSyntax
5+import Idris.AbsSyntax hiding (TypeCase)
66import IRTS.Bytecode
77import IRTS.Lang
88import IRTS.Simplified
@@ -14,16 +14,187 @@ import Util.System
1414import Control.Arrow
1515import Data.Char
1616import Data.List
17−import qualified Data.Map as Map
1817import System.IO
1918import System.Directory
2019
2120idrNamespace :: String
22−idrNamespace = "__IDR__"
21+idrNamespace = "__IDR__"
2322idrRTNamespace = "__IDRRT__"
2423
2524data JSTarget = Node | JavaScript deriving Eq
2625
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+
27198codegenJavaScript
28199 :: JSTarget
29200 -> [(Name, SDecl)]
@@ -39,26 +210,29 @@ codegenJavaScript target definitions filename outputType = do
39210 path <- getDataDir
40211 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
41212 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
42− writeFile filename ( header
43− ++ idrRuntime
44− ++ tgtRuntime
45− ++ functions
46− ++ mainLoop)
213+ writeFile filename $ intercalate "\n" $ [ header
214+ , idrRuntime
215+ , tgtRuntime
216+ ] ++ functions ++ [mainLoop]
47217
48218 setPermissions filename (emptyPermissions { readable = True
49219 , executable = target == Node
50220 , writable = True
51221 })
52222 where
223+ def :: [(String, SDecl)]
53224 def = map (first translateNamespace) definitions
54−
55− functions = concatMap translateDeclaration def
225+
226+ functions :: [String]
227+ functions = map (compileJS . translateDeclaration) def
56228
57229 mainLoop :: String
58− mainLoop = intercalate "\n" [ "\nfunction main() {"
59− , createTailcall "__IDR__runMain0()"
60− , "}\n\nmain();\n"
61− ]
230+ mainLoop = compileJS $
231+ JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
232+ jsTailcall $ jsCall "__IDR__runMain0" []
233+ )
234+ , jsCall "main" []
235+ ]
62236
63237translateIdentifier :: String -> String
64238translateIdentifier =
@@ -99,14 +273,14 @@ translateIdentifier =
99273 , "void"
100274 , "while"
101275 , "with"
102−
276+
103277 , "class"
104278 , "enum"
105279 , "export"
106280 , "extends"
107281 , "import"
108282 , "super"
109−
283+
110284 , "implements"
111285 , "interface"
112286 , "let"
@@ -128,106 +302,102 @@ translateName (UN name) = translateIdentifier name
128302translateName (NS name _) = translateName name
129303translateName (MN i name) = translateIdentifier name ++ show i
130304
131−translateConstant :: Const -> String
132−translateConstant (I i) = show i
133−translateConstant (BI i) = idrRTNamespace ++ "bigInt('" ++ show i ++ "')"
134−translateConstant (Fl f) = show f
135−translateConstant (Ch c) = show c
136−translateConstant (Str s) = show s
137−translateConstant (AType (ATInt ITNative)) = idrRTNamespace ++ "Int"
138−translateConstant StrType = idrRTNamespace ++ "String"
139−translateConstant (AType (ATInt ITBig)) = idrRTNamespace ++ "Integer"
140−translateConstant (AType ATFloat) = idrRTNamespace ++ "Float"
141−translateConstant (AType (ATInt ITChar)) = idrRTNamespace ++ "Char"
142−translateConstant PtrType = idrRTNamespace ++ "Ptr"
143−translateConstant Forgot = idrRTNamespace ++ "Forgot"
144−translateConstant c =
145− "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
146−
147−translateParameterlist =
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
305+translateConstant :: Const -> JS
306+translateConstant (I i) = JSNum (JSInt i)
307+translateConstant (Fl f) = JSNum (JSFloat f)
308+translateConstant (Ch c) = JSString [c]
309+translateConstant (Str s) = JSString s
310+translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
311+translateConstant StrType = JSType JSStringTy
312+translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
313+translateConstant (AType ATFloat) = JSType JSFloatTy
314+translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
315+translateConstant PtrType = JSType JSPtrTy
316+translateConstant Forgot = JSType JSForgotTy
317+translateConstant (BI i) = jsBigInt $ JSNum (JSInteger i)
318+translateConstant c =
319+ JSError $ "Unimplemented Constant: " ++ show c
320+
321+translateDeclaration :: (String, SDecl) -> JS
153322translateDeclaration (path, SFun name params stackSize body) =
154− "var " ++ path ++ translateName name
155− ++ " = function("
156− ++ intercalate "," p
157− ++ "){\n"
158− ++ concatMap assignVar (zip [0..] p)
159− ++ concatMap allocVar [numP..(numP+stackSize-1)]
160− ++ "return "
161− ++ translateExpression body
162− ++ ";\n};\n"
163− where
323+ JSAlloc (path ++ translateName name) $ Just $ JSFunction p (
324+ JSSeq $
325+ zipWith assignVar [0..] p ++
326+ map allocVar [numP .. (numP + stackSize - 1)] ++
327+ [JSReturn $ translateExpression body]
328+ )
329+ where
164330 numP :: Int
165331 numP = length params
166332
167− allocVar :: Int -> String
168− allocVar n = "var __var_" ++ show n ++ ";\n"
333+ allocVar :: Int -> JS
334+ allocVar n = JSAlloc (jsVar n) Nothing
169335
170− assignVar :: (Int, String) -> String
171− assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
336+ assignVar :: Int -> String -> JS
337+ assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
172338
173339 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
175347
176348translateVariableName :: LVar -> String
177349translateVariableName (Loc i) =
178− "__var_" ++ show i
350+ jsVar i
179351
180−translateExpression :: SExp -> String
352+translateExpression :: SExp -> JS
181353translateExpression (SLet name value body) =
182− "(function("
183− ++ translateVariableName name
184− ++ "){\nreturn "
185− ++ translateExpression body
186− ++ ";\n})("
187− ++ translateExpression value
188− ++ ")"
354+ JSApp (
355+ JSFunction [translateVariableName name] (
356+ JSReturn $ translateExpression body
357+ )
358+ ) [translateExpression value]
189359
190360translateExpression (SConst cst) =
191361 translateConstant cst
192362
193363translateExpression (SV var) =
194− translateVariableName var
195−
196−translateExpression (SApp False name vars) =
197− createTailcall $ translateFunctionCall name vars
198−
199−translateExpression (SApp True name vars) =
200− "new " ++ idrRTNamespace ++ "Tailcall("
201− ++ "function(){\n"
202− ++ "return " ++ translateFunctionCall name vars
203− ++ ";\n})"
364+ JSVar var
365+
366+translateExpression (SApp tc name vars)
367+ | False <- tc =
368+ jsTailcall $ translateFunctionCall name vars
369+ | True <- tc =
370+ JSNew (idrRTNamespace ++ "Tailcall") [JSFunction [] (
371+ JSReturn $ translateFunctionCall name vars
372+ )]
373+ where
374+ translateFunctionCall name vars =
375+ jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
204376
205377translateExpression (SOp op vars)
206− | LNoOp <- op = translateVariableName (last vars)
207−
208− | (LZExt _ ITBig) <- op =
209− idrRTNamespace ++ "bigInt(" ++ translateVariableName (last vars) ++ ")"
378+ | LNoOp <- op = JSVar (last vars)
210379
380+ | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
211381 | (LPlus (ATInt ITBig)) <- op
212− , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
382+ , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
213383 | (LMinus (ATInt ITBig)) <- op
214− , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
384+ , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
215385 | (LTimes (ATInt ITBig)) <- op
216− , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
386+ , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
217387 | (LSDiv (ATInt ITBig)) <- op
218− , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
388+ , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
219389 | (LSRem (ATInt ITBig)) <- op
220− , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
390+ , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
221391 | (LEq (ATInt ITBig)) <- op
222− , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
392+ , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
223393 | (LSLt (ATInt ITBig)) <- op
224− , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
394+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
225395 | (LSLe (ATInt ITBig)) <- op
226− , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
396+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
227397 | (LSGt (ATInt ITBig)) <- op
228− , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
398+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
229399 | (LSGe (ATInt ITBig)) <- op
230− , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
400+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
231401
232402 | (LPlus ATFloat) <- op
233403 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
@@ -279,7 +449,7 @@ translateExpression (SOp op vars)
279449 | (LASHR _) <- op
280450 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
281451 | (LCompl _) <- op
282− , (arg:_) <- vars = '~' : translateVariableName arg
452+ , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
283453
284454 | LStrConcat <- op
285455 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
@@ -288,126 +458,122 @@ translateExpression (SOp op vars)
288458 | LStrLt <- op
289459 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
290460 | LStrLen <- op
291− , (arg:_) <- vars = translateVariableName arg ++ ".length"
461+ , (arg:_) <- vars = JSProj (JSVar arg) "length"
292462
293463 | (LStrInt ITNative) <- op
294− , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
464+ , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
295465 | (LIntStr ITNative) <- op
296− , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
466+ , (arg:_) <- vars = jsCall "String" [JSVar arg]
297467 | (LSExt ITNative ITBig) <- op
298− , (arg:_) <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")"
468+ , (arg:_) <- vars = jsBigInt $ JSVar arg
299469 | (LTrunc ITBig ITNative) <- op
300− , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
470+ , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
301471 | (LIntStr ITBig) <- op
302− , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
472+ , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
303473 | (LStrInt ITBig) <- op
304− , (arg:_) <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")"
474+ , (arg:_) <- vars = jsBigInt $ JSVar arg
305475 | LFloatStr <- op
306− , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
476+ , (arg:_) <- vars = jsCall "String" [JSVar arg]
307477 | LStrFloat <- op
308− , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
478+ , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
309479 | (LIntFloat ITNative) <- op
310− , (arg:_) <- vars = translateVariableName arg
480+ , (arg:_) <- vars = JSVar arg
311481 | (LFloatInt ITNative) <- op
312− , (arg:_) <- vars = translateVariableName arg
482+ , (arg:_) <- vars = JSVar arg
313483 | (LChInt ITNative) <- op
314− , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
484+ , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
315485 | (LIntCh ITNative) <- op
316− , (arg:_) <- vars =
317− "String.fromCharCode(" ++ translateVariableName arg ++ ")"
486+ , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
318487
319488 | LFExp <- op
320− , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
489+ , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
321490 | LFLog <- op
322− , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
491+ , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
323492 | LFSin <- op
324− , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
493+ , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
325494 | LFCos <- op
326− , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
495+ , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
327496 | LFTan <- op
328− , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
497+ , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
329498 | LFASin <- op
330− , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
499+ , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
331500 | LFACos <- op
332− , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
501+ , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
333502 | LFATan <- op
334− , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
503+ , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
335504 | LFSqrt <- op
336− , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
505+ , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
337506 | LFFloor <- op
338− , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
507+ , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
339508 | LFCeil <- op
340− , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
509+ , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
341510
342511 | LStrCons <- op
343512 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
344513 | LStrHead <- op
345− , (arg:_) <- vars = translateVariableName arg ++ "[0]"
514+ , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
346515 | LStrRev <- op
347− , (arg:_) <- vars = let v = translateVariableName arg in
348− v ++ ".split('').reverse().join('')"
516+ , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
349517 | LStrIndex <- op
350− , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
351− r = translateVariableName rhs in
352− l ++ "[" ++ r ++ "]"
518+ , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
353519 | LStrTail <- op
354520 , (arg:_) <- vars = let v = translateVariableName arg in
355− v ++ ".substr(1," ++ v ++ ".length-1)"
521+ JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
356522 where
357− translateBinaryOp :: String -> LVar -> LVar -> String
358− translateBinaryOp f lhs rhs =
359− translateVariableName lhs
360− ++ f
361− ++ translateVariableName rhs
523+ translateBinaryOp :: String -> LVar -> LVar -> JS
524+ translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
525+
526+ invokeMeth :: LVar -> String -> [LVar] -> JS
527+ invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
362528
363529translateExpression (SError msg) =
364− "(function(){throw \'" ++ msg ++ "\';})()"
530+ JSError msg
365531
366532translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
367− idrRTNamespace ++ "print(" ++ translateVariableName var ++ ")"
533+ jsCall (idrRTNamespace ++ "print") [JSVar var]
368534
369535translateExpression (SForeign _ _ fun args)
370536 | "[]=" `isSuffixOf` fun
371537 , (obj:idx:val:[]) <- args =
372− concat [object obj, index idx, assign val]
538+ JSRaw $ concat [object obj, index idx, assign val]
373539
374540 | "[]" `isSuffixOf` fun
375541 , (obj:idx:[]) <- args =
376− object obj ++ index idx
542+ JSRaw $ object obj ++ index idx
377543
378544 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
379545 , (obj:val:[]) <- args =
380− concat [object obj, '[' : name ++ "]", assign val]
546+ JSRaw $ concat [object obj, '[' : name ++ "]", assign val]
381547
382548 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
383549 , (obj:[]) <- args =
384− object obj ++ '[' : name ++ "]"
550+ JSRaw $ object obj ++ '[' : name ++ "]"
385551
386552 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
387553 , (obj:val:[]) <- args =
388− concat [object obj, field, assign val]
554+ JSRaw $ concat [object obj, field, assign val]
389555
390556 | "." `isPrefixOf` fun
391557 , (obj:[]) <- args =
392− object obj ++ field
558+ JSRaw $ object obj ++ field
393559
394560 | "." `isPrefixOf` fun
395561 , (obj:[(FUnit, _)]) <- args =
396− concat [object obj, method, "()"]
397−
562+ JSRaw $ concat [object obj, method, "()"]
563+
398564 | "." `isPrefixOf` fun
399565 , (obj:as) <- args =
400− concat [object obj, method, arguments as]
566+ JSRaw $ concat [object obj, method, arguments as]
401567
402568 | "[]=" `isSuffixOf` fun
403569 , (idx:val:[]) <- args =
404− concat [array, index idx, assign val]
570+ JSRaw $ concat [array, index idx, assign val]
405571
406572 | "[]" `isSuffixOf` fun
407573 , (idx:[]) <- args =
408− array ++ index idx
574+ JSRaw $ array ++ index idx
409575
410− | otherwise = fun ++ arguments args
576+ | otherwise = JSRaw $ fun ++ arguments args
411577 where
412578 name = filter (`notElem` "[]=") fun
413579 method = name
@@ -420,101 +586,89 @@ translateExpression (SForeign _ _ fun args)
420586 '(' : intercalate "," (map generateWrapper as) ++ ")"
421587
422588 generateWrapper (ffunc, name)
423− | FFunction <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
424− | FFunctionIO <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
589+ | FFunction <- ffunc =
590+ idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
591+ | FFunctionIO <- ffunc =
592+ idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
425593
426594 generateWrapper (_, name) =
427595 translateVariableName name
428596
429−translateExpression (SChkCase var cases) =
430− "(function(e){\n"
431− ++ intercalate " else " (map (translateCase "e") cases)
432− ++ "\n})("
433− ++ translateVariableName var
434− ++ ")"
435−
436−translateExpression (SCase var cases) =
437− "(function(e){\n"
438− ++ intercalate " else " (map (translateCase "e") cases)
439− ++ "\n})("
440− ++ translateVariableName var
441− ++ ")"
597+translateExpression patterncase
598+ | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
599+ | (SCase var cases) <- patterncase = caseHelper var cases "cse"
600+ where
601+ caseHelper var cases param =
602+ JSApp (JSFunction [param] (
603+ JSCond $ map ((expandCase param) . translateCase param) cases
604+ )) [JSVar var]
605+
606+ expandCase :: String -> (Cond, JS) -> (JS, JS)
607+ expandCase _ (RawCond cond, branch) = (cond, branch)
608+ expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
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)
442619
443620translateExpression (SCon i name vars) =
444− concat [ "new " ++ idrRTNamespace ++ "Con("
445− , show i
446− , ",["
447− , intercalate "," $ map translateVariableName vars
448− , "])"
449− ]
621+ JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
622+ , JSArray $ map JSVar vars
623+ ]
450624
451625translateExpression (SUpdate var e) =
452− translateVariableName var ++ " = " ++ translateExpression e
626+ JSAssign (JSVar var) (translateExpression e)
453627
454628translateExpression (SProj var i) =
455− translateVariableName var ++ ".vars[" ++ show i ++"]"
629+ JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
456630
457−translateExpression SNothing = "null"
631+translateExpression SNothing = JSNull
458632
459633translateExpression e =
460− "(function(){throw 'Not yet implemented: "
461− ++ filter (/= '\'') (show e)
462− ++ "';})()"
634+ JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
635+
636+data CaseType = ConCase Int
637+ | TypeCase JSType
638+ | DefaultCase
639+ deriving Eq
640+
641+data Cond = CaseCond CaseType
642+ | RawCond JS
463643
464−translateCase :: String -> SAlt -> String
644+translateCase :: String -> SAlt -> (Cond, JS)
465645translateCase _ (SDefaultCase e) =
466− createIfBlock "true" (translateExpression e)
646+ (CaseCond DefaultCase, translateExpression e)
467647
468648translateCase var (SConstCase ty e)
469− | StrType <- ty = matchHelper "String"
470− | PtrType <- ty = matchHelper "Ptr"
471− | Forgot <- ty = matchHelper "Forgot"
472− | (AType ATFloat) <- ty = matchHelper "Float"
473− | (AType (ATInt ITBig)) <- ty = matchHelper "Integer"
474− | (AType (ATInt ITNative)) <- ty = matchHelper "Int"
475− | (AType (ATInt ITChar)) <- ty = matchHelper "Char"
649+ | StrType <- ty = matchHelper JSStringTy
650+ | PtrType <- ty = matchHelper JSPtrTy
651+ | Forgot <- ty = matchHelper JSForgotTy
652+ | (AType ATFloat) <- ty = matchHelper JSFloatTy
653+ | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
654+ | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
655+ | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
476656 where
477− matchHelper tyName = translateTypeMatch var tyName e
657+ matchHelper :: JSType -> (Cond, JS)
658+ matchHelper ty = (CaseCond $ TypeCase ty, translateExpression e)
478659
479660translateCase var (SConstCase cst@(BI _) e) =
480− let cond = idrRTNamespace ++ "bigInt(" ++ var ++ ").equals(" ++ translateConstant cst ++ ")" in
481− createIfBlock cond (translateExpression e)
661+ let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
662+ (RawCond cond, translateExpression e)
482663
483664translateCase var (SConstCase cst e) =
484− let cond = var ++ " == " ++ translateConstant cst in
485− createIfBlock cond (translateExpression e)
486−
487−translateCase var (SConCase a i name vars e) =
488− let isCon = var ++ " instanceof " ++ idrRTNamespace ++ "Con"
489− isI = show i ++ " == " ++ var ++ ".i"
490− params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
491− args = ".apply(this," ++ var ++ ".vars)"
492− f b =
493− "(function("
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− ++ ")"
665+ let cond = JSRaw var `jsEq` translateConstant cst in
666+ (RawCond cond, translateExpression e)
667+
668+translateCase var (SConCase a tag name vars e) =
669+ let params = map jsVar [a .. (a + length vars)] in
670+ (CaseCond $ ConCase tag,
671+ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
672+ JSThis, JSProj (JSRaw var) "vars"
673+ ]
674+ )