git.iko.soy/Idris-dev
on aa8aefd help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
501 lines 22 kB history raw
1{-# LANGUAGE PatternGuards #-}
3{-
4 BigInteger Javascript code taken from:
5 https://github.com/peterolson/BigInteger.js
6-}
8module IRTS.CodegenJavaScript (codegenJavaScript) where
10import Idris.AbsSyntax
11import IRTS.Bytecode
12import IRTS.Lang
13import IRTS.Simplified
14import IRTS.CodegenCommon
15import Core.TT
16import Paths_idris
17import Util.System
19import Control.Arrow
20import Data.Char
21import Data.List
22import System.IO
24type NamespaceName = String
26idrNamespace :: NamespaceName
27idrNamespace = "__IDR__"
29codegenJavaScript
30 :: [(Name, SDecl)]
31 -> FilePath
32 -> OutputType
33 -> IO ()
34codegenJavaScript definitions filename outputType =
35 writeFile filename output
36 where
37 def = map (first translateNamespace) definitions
39 mainLoop :: String
40 mainLoop = intercalate "\n" [ "\nfunction main() {"
41 , createTailcall "__IDR__.runMain0()"
42 , "}\n\nmain();\n"
43 ]
45 output :: String
46 output = concat [ idrRuntime
47 , concatMap (translateModule Nothing) def
48 , mainLoop
49 ]
51idrRuntime :: String
52idrRuntime =
53 createModule Nothing idrNamespace $ concat
54 [ "__IDR__.Type = function(type) { this.type = type; };"
55 , "__IDR__.Int = new __IDR__.Type('Int');"
56 , "__IDR__.Char = new __IDR__.Type('Char');"
57 , "__IDR__.String = new __IDR__.Type('String');"
58 , "__IDR__.Integer = new __IDR__.Type('Integer');"
59 , "__IDR__.Float = new __IDR__.Type('Float');"
60 , "__IDR__.Forgot = new __IDR__.Type('Forgot');"
62 , "__IDR__.bigInt=function(){var e=1e7,t=7,n={positive:!1,negative:!0},r=function(e,t){var n=e.value,r=t.value,i=n.length>r.length?n.length:r.length;for(var s=0;s<i;s++)n[s]=n[s]||0,r[s]=r[s]||0;for(var s=i-1;s>=0;s--){if(n[s]!==0||r[s]!==0)break;n.pop(),r.pop()}n.length||(n=[0],r=[0]),e.value=n,t.value=r},i=function(e,s){if(typeof e=='object')return e;e+='';var u=n.positive,a=[];e[0]==='-'&&(u=n.negative,e=e.slice(1));var e=e.split('e');if(e.length>2)throw new Error('Invalid integer');if(e[1]){var f=e[1];f[0]==='+'&&(f=f.slice(1)),f=i(f);if(f.lesser(0))throw new Error('Cannot include negative exponent part for integers');while(f.notEquals(0))e[0]+='0',f=f.prev()}e=e[0],e==='-0'&&(e='0');var l=/^([1-9][0-9]*)$|^0$/.test(e);if(!l)throw new Error('Invalid integer');while(e.length){var c=e.length>t?e.length-t:0;a.push(+e.slice(c)),e=e.slice(0,c)}var h=o(a,u);return s&&r(s,h),h},s=function(e,t){var e=o(e,n.positive),t=o(t,n.positive);if(e.equals(0))throw new Error('Cannot divide by 0');var r=0;do{var i=1,s=o(e.value,n.positive),u=s.times(10);while(u.lesser(t))s=u,i*=10,u=u.times(10);while(s.lesserOrEquals(t))t=t.minus(s),r+=i}while(e.lesserOrEquals(t));return{remainder:t.value,result:r}},o=function(f,l){var c={value:f,sign:l},h={value:f,sign:l,negate:function(e){var t=e||c;return o(t.value,!t.sign)},abs:function(e){var t=e||c;return o(t.value,n.positive)},add:function(t,s){var u,a=c,f;s?(a=i(t))&&(f=i(s)):f=i(t,a),u=a.sign;if(a.sign!==f.sign)return a=o(a.value,n.positive),f=o(f.value,n.positive),u===n.positive?h.subtract(a,f):h.subtract(f,a);r(a,f);var l=a.value,p=f.value,d=[],v=0;for(var m=0;m<l.length||v>0;m++){var g=l[m]+p[m]+v;v=g>e?1:0,g-=v*e,d.push(g)}return o(d,u)},plus:function(e,t){return h.add(e,t)},subtract:function(t,r){var s=c,u;r?(s=i(t))&&(u=i(r)):u=i(t,s);if(s.sign!==u.sign)return h.add(s,h.negate(u));if(s.sign===n.negative)return h.subtract(h.negate(u),h.negate(s));if(h.compare(s,u)===-1)return h.negate(h.subtract(u,s));var a=s.value,f=u.value,l=[],p=0;for(var d=0;d<a.length;d++){a[d]-=p,p=a[d]<f[d]?1:0;var v=p*e+a[d]-f[d];l.push(v)}return o(l,n.positive)},minus:function(e,t){return h.subtract(e,t)},multiply:function(t,n){var r,s=c,u;n?(s=i(t))&&(u=i(n)):u=i(t,s),r=s.sign!==u.sign;var a=s.value,f=u.value,l=[];for(var h=0;h<a.length;h++){l[h]=[];var p=h;while(p--)l[h].push(0)}var d=0;for(var h=0;h<a.length;h++){var v=a[h];for(var p=0;p<f.length||d>0;p++){var m=f[p],g=m?v*m+d:d;d=g>e?Math.floor(g/e):0,g-=d*e,l[h].push(g)}}var y=-1;for(var h=0;h<l.length;h++){var b=l[h].length;b>y&&(y=b)}var w=[],d=0;for(var h=0;h<y||d>0;h++){var E=d;for(var p=0;p<l.length;p++)E+=l[p][h]||0;d=E>e?Math.floor(E/e):0,E-=d*e,w.push(E)}return o(w,r)},times:function(e,t){return h.multiply(e,t)},divmod:function(e,t){var r,u=c,a;t?(u=i(e))&&(a=i(t)):a=i(e,u),r=u.sign!==a.sign;if(o(u.value,u.sign).equals(0))return{quotient:o([0],n.positive),remainder:o([0],n.positive)};if(a.equals(0))throw new Error('Cannot divide by zero');var f=u.value,l=a.value,h=[],p=[];for(var d=f.length-1;d>=0;d--){var e=[f[d]].concat(p),v=s(l,e);h.push(v.result),p=v.remainder}return h.reverse(),{quotient:o(h,r),remainder:o(p,u.sign)}},divide:function(e,t){return h.divmod(e,t).quotient},over:function(e,t){return h.divide(e,t)},mod:function(e,t){return h.divmod(e,t).remainder},pow:function(e,t){var n=c,r;t?(n=i(e))&&(r=i(t)):r=i(e,n);var s=n,f=r;if(f.lesser(0))return u;if(f.equals(0))return a;var l=o(s.value,s.sign);if(f.mod(2).equals(0)){var h=l.pow(f.over(2));return h.times(h)}return l.times(l.pow(f.minus(1)))},next:function(e){var t=e||c;return h.add(t,1)},prev:function(e){var t=e||c;return h.subtract(t,1)},compare:function(e,t){var s=c,o;t?(s=i(e))&&(o=i(t,s)):o=i(e,s),r(s,o);if(s.value.length===1&&o.value.length===1&&s.value[0]===0&&o.value[0]===0)return 0;if(o.sign!==s.sign)return s.sign===n.positive?1:-1;var u=s.sign===n.positive?1:-1,a=s.value,f=o.value;for(var l=a.length-1;l>=0;l--){if(a[l]>f[l])return 1*u;if(f[l]>a[l])return-1*u}return 0},compareAbs:function(e,t){var r=c,s;return t?(r=i(e))&&(s=i(t,r)):s=i(e,r),r.sign=s.sign=n.positive,h.compare(r,s)},equals:function(e,t){return h.compare(e,t)===0},notEquals:function(e,t){return!h.equals(e,t)},lesser:function(e,t){return h.compare(e,t)<0},greater:function(e,t){return h.compare(e,t)>0},greaterOrEquals:function(e,t){return h.compare(e,t)>=0},lesserOrEquals:function(e,t){return h.compare(e,t)<=0},isPositive:function(e){var t=e||c;return t.sign===n.positive},isNegative:function(e){var t=e||c;return t.sign===n.negative},isEven:function(e){var t=e||c;return t.value[0]%2===0},isOdd:function(e){var t=e||c;return t.value[0]%2===1},toString:function(r){var i=r||c,s='',o=i.value.length;while(o--)s+=(e.toString()+i.value[o]).slice(-t);while(s[0]==='0')s=s.slice(1);s.length||(s='0');var u=i.sign===n.positive?'':'-';return u+s},toJSNumber:function(e){return+h.toString(e)},valueOf:function(e){return h.toJSNumber(e)}};return h},u=o([0],n.positive),a=o([1],n.positive),f=o([1],n.negative),l=function(e){return typeof e=='undefined'?u:i(e)};return l.zero=u,l.one=a,l.minusOne=f,l}();typeof module!='undefined'&&(module.exports=__IDR__.bigInt);"
64 , "__IDR__.Tailcall = function(f) { this.f = f };"
66 , "__IDR__.Con = function(i,name,vars)"
67 , "{this.i = i;this.name = name;this.vars = vars;};\n"
69 , "__IDR__.tailcall = function(f){\n"
70 ++ "var __f = f;\n"
71 ++ "while (__f) {\n"
72 ++ "var f = __f;\n"
73 ++ "__f = null;\n"
74 ++ "var ret = f();\n"
75 ++ "if (ret instanceof __IDR__.Tailcall) {\n"
76 ++ "__f = ret.f;"
77 ++ "\n} else {\n"
78 ++ "return ret;"
79 ++ "\n}"
80 ++ "\n}"
81 ++ "\n};\n"
83 , "var newline_regex =/(.*)\\n$/;\n"
85 , "__IDR__.print = function(s){\n"
86 ++ "var m = s.match(newline_regex);\n"
87 ++ "console.log(m ? m[1] : s);"
88 ++ "\n};\n"
89 ]
91createModule :: Maybe String -> NamespaceName -> String -> String
92createModule toplevel modname body =
93 concat [header modname, body, footer modname]
94 where
95 header :: NamespaceName -> String
96 header modname =
97 concatMap (++ "\n")
98 [ "\nvar " ++ modname ++ ";"
99 , "(function(" ++ modname ++ "){"
100 ]
102 footer :: NamespaceName -> String
103 footer modname =
104 let m = maybe "" (++ ".") toplevel ++ modname in
105 "\n})("
106 ++ m
107 ++ " || ("
108 ++ m
109 ++ " = {})"
110 ++ ");\n"
112translateModule :: Maybe String -> ([String], SDecl) -> String
113translateModule toplevel ([modname], decl) =
114 let body = translateDeclaration modname decl in
115 createModule toplevel modname body
116translateModule toplevel (n:ns, decl) =
117 createModule toplevel n $ translateModule (Just n) (ns, decl)
119translateIdentifier :: String -> String
120translateIdentifier =
121 concatMap replaceBadChars
122 where replaceBadChars :: Char -> String
123 replaceBadChars ' ' = "_"
124 replaceBadChars '_' = "__"
125 replaceBadChars '@' = "_at"
126 replaceBadChars '[' = "_OSB"
127 replaceBadChars ']' = "_CSB"
128 replaceBadChars '(' = "_OP"
129 replaceBadChars ')' = "_CP"
130 replaceBadChars '{' = "_OB"
131 replaceBadChars '}' = "_CB"
132 replaceBadChars '!' = "_bang"
133 replaceBadChars '#' = "_hash"
134 replaceBadChars '.' = "_dot"
135 replaceBadChars ',' = "_comma"
136 replaceBadChars ':' = "_colon"
137 replaceBadChars '+' = "_plus"
138 replaceBadChars '-' = "_minus"
139 replaceBadChars '*' = "_times"
140 replaceBadChars '<' = "_lt"
141 replaceBadChars '>' = "_gt"
142 replaceBadChars '=' = "_eq"
143 replaceBadChars '|' = "_pipe"
144 replaceBadChars '&' = "_amp"
145 replaceBadChars '/' = "_SL"
146 replaceBadChars '\\' = "_BSL"
147 replaceBadChars '%' = "_per"
148 replaceBadChars '?' = "_que"
149 replaceBadChars '~' = "_til"
150 replaceBadChars '\'' = "_apo"
151 replaceBadChars c
152 | isDigit c = "_" ++ [c] ++ "_"
153 | otherwise = [c]
155translateNamespace :: Name -> [String]
156translateNamespace (UN _) = [idrNamespace]
157translateNamespace (NS _ ns) = idrNamespace : map translateIdentifier ns
158translateNamespace (MN _ _) = [idrNamespace]
160translateName :: Name -> String
161translateName (UN name) = translateIdentifier name
162translateName (NS name _) = translateName name
163translateName (MN i name) = translateIdentifier name ++ show i
165translateQualifiedName :: Name -> String
166translateQualifiedName name =
167 intercalate "." (translateNamespace name) ++ "." ++ translateName name
169translateConstant :: Const -> String
170translateConstant (I i) = show i
171translateConstant (BI i) = "__IDR__.bigInt('" ++ show i ++ "')"
172translateConstant (Fl f) = show f
173translateConstant (Ch c) = show c
174translateConstant (Str s) = show s
175translateConstant IType = "__IDR__.Int"
176translateConstant ChType = "__IDR__.Char"
177translateConstant StrType = "__IDR__.String"
178translateConstant BIType = "__IDR__.Integer"
179translateConstant FlType = "__IDR__.Float"
180translateConstant Forgot = "__IDR__.Forgot"
181translateConstant c =
182 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"
184translateParameterlist =
185 map translateParameter
186 where translateParameter (MN i name) = name ++ show i
187 translateParameter (UN name) = name
189translateDeclaration :: NamespaceName -> SDecl -> String
190translateDeclaration modname (SFun name params stackSize body) =
191 modname
192 ++ "."
193 ++ translateName name
194 ++ " = function("
195 ++ intercalate "," p
196 ++ "){\n"
197 ++ concatMap assignVar (zip [0..] p)
198 ++ concatMap allocVar [numP..(numP+stackSize-1)]
199 ++ "return "
200 ++ translateExpression modname body
201 ++ ";\n};\n"
202 where
203 numP :: Int
204 numP = length params
206 allocVar :: Int -> String
207 allocVar n = "var __var_" ++ show n ++ ";\n"
209 assignVar :: (Int, String) -> String
210 assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"
212 p :: [String]
213 p = translateParameterlist params
215translateVariableName :: LVar -> String
216translateVariableName (Loc i) =
217 "__var_" ++ show i
219translateExpression :: NamespaceName -> SExp -> String
220translateExpression modname (SLet name value body) =
221 "(function("
222 ++ translateVariableName name
223 ++ "){\nreturn "
224 ++ translateExpression modname body
225 ++ ";\n})("
226 ++ translateExpression modname value
227 ++ ")"
229translateExpression _ (SConst cst) =
230 translateConstant cst
232translateExpression _ (SV var) =
233 translateVariableName var
235translateExpression modname (SApp False name vars) =
236 createTailcall $ translateFunctionCall name vars
238translateExpression modname (SApp True name vars) =
239 "new __IDR__.Tailcall("
240 ++ "function(){\n"
241 ++ "return " ++ translateFunctionCall name vars
242 ++ ";\n});"
244translateExpression _ (SOp op vars)
245 | LPlus <- op
246 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
247 | LMinus <- op
248 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
249 | LTimes <- op
250 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
251 | LDiv <- op
252 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
253 | LMod <- op
254 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
255 | LEq <- op
256 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
257 | LLt <- op
258 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
259 | LLe <- op
260 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
261 | LGt <- op
262 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
263 | LGe <- op
264 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
265 | LAnd <- op
266 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
267 | LOr <- op
268 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
269 | LXOr <- op
270 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
271 | LSHL <- op
272 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
273 | LSHR <- op
274 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
275 | LCompl <- op
276 , (arg:_) <- vars = '~' : translateVariableName arg
278 | LBPlus <- op
279 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
280 | LBMinus <- op
281 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
282 | LBTimes <- op
283 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
284 | LBDiv <- op
285 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
286 | LBMod <- op
287 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
288 | LBEq <- op
289 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
290 | LBLt <- op
291 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
292 | LBLe <- op
293 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
294 | LBGt <- op
295 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
296 | LBGe <- op
297 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
299 | LFPlus <- op
300 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
301 | LFMinus <- op
302 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
303 | LFTimes <- op
304 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
305 | LFDiv <- op
306 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
307 | LFEq <- op
308 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
309 | LFLt <- op
310 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
311 | LFLe <- op
312 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
313 | LFGt <- op
314 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
315 | LFGe <- op
316 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
318 | LStrConcat <- op
319 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
320 | LStrEq <- op
321 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
322 | LStrLt <- op
323 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
324 | LStrLen <- op
325 , (arg:_) <- vars = translateVariableName arg ++ ".length"
327 | LStrInt <- op
328 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
329 | LIntStr <- op
330 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
331 | LIntBig <- op
332 , (arg:_) <- vars = "__IDR__.bigint(" ++ translateVariableName arg ++ ")"
333 | LBigInt <- op
334 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"
335 | LBigStr <- op
336 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"
337 | LStrBig <- op
338 , (arg:_) <- vars = "__IDR__.bigint(" ++ translateVariableName arg ++ ")"
339 | LFloatStr <- op
340 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"
341 | LStrFloat <- op
342 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
343 | LIntFloat <- op
344 , (arg:_) <- vars = translateVariableName arg
345 | LFloatInt <- op
346 , (arg:_) <- vars = translateVariableName arg
347 | LChInt <- op
348 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"
349 | LIntCh <- op
350 , (arg:_) <- vars =
351 "String.fromCharCode(" ++ translateVariableName arg ++ ")"
353 | LFExp <- op
354 , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
355 | LFLog <- op
356 , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
357 | LFSin <- op
358 , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
359 | LFCos <- op
360 , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
361 | LFTan <- op
362 , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
363 | LFASin <- op
364 , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
365 | LFACos <- op
366 , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
367 | LFATan <- op
368 , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
369 | LFSqrt <- op
370 , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
371 | LFFloor <- op
372 , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
373 | LFCeil <- op
374 , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"
376 | LStrCons <- op
377 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
378 | LStrHead <- op
379 , (arg:_) <- vars = translateVariableName arg ++ "[0]"
380 | LStrRev <- op
381 , (arg:_) <- vars = let v = translateVariableName arg in
382 v ++ "split('').reverse().join('')"
383 | LStrIndex <- op
384 , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
385 r = translateVariableName rhs in
386 l ++ "[" ++ r ++ "]"
387 | LStrTail <- op
388 , (arg:_) <- vars = let v = translateVariableName arg in
389 v ++ ".substr(1," ++ v ++ ".length-1)"
390 where
391 translateBinaryOp :: String -> LVar -> LVar -> String
392 translateBinaryOp f lhs rhs =
393 translateVariableName lhs
394 ++ f
395 ++ translateVariableName rhs
397translateExpression _ (SError msg) =
398 "(function(){throw \'" ++ msg ++ "\';})();"
400translateExpression _ (SForeign _ _ "putStr" [(FString, var)]) =
401 "__IDR__.print(" ++ translateVariableName var ++ ");"
403translateExpression _ (SForeign _ _ fun args) =
404 fun
405 ++ "("
406 ++ intercalate "," (map (translateVariableName . snd) args)
407 ++ ");"
409translateExpression modname (SChkCase var cases) =
410 "(function(e){\n"
411 ++ intercalate " else " (map (translateCase modname "e") cases)
412 ++ "\n})("
413 ++ translateVariableName var
414 ++ ")"
416translateExpression modname (SCase var cases) =
417 "(function(e){\n"
418 ++ intercalate " else " (map (translateCase modname "e") cases)
419 ++ "\n})("
420 ++ translateVariableName var
421 ++ ")"
423translateExpression _ (SCon i name vars) =
424 concat [ "new __IDR__.Con("
425 , show i
426 , ","
427 , '\'' : translateQualifiedName name ++ "\',["
428 , intercalate "," $ map translateVariableName vars
429 , "])"
430 ]
432translateExpression modname (SUpdate var e) =
433 translateVariableName var ++ " = " ++ translateExpression modname e
435translateExpression modname (SProj var i) =
436 translateVariableName var ++ ".vars[" ++ show i ++"]"
438translateExpression _ SNothing = "null"
440translateExpression _ e =
441 "(function(){throw 'Not yet implemented: "
442 ++ filter (/= '\'') (show e)
443 ++ "';})()"
445translateCase :: String -> String -> SAlt -> String
446translateCase modname _ (SDefaultCase e) =
447 createIfBlock "true" (translateExpression modname e)
449translateCase modname var (SConstCase ty e)
450 | ChType <- ty = matchHelper "Char"
451 | StrType <- ty = matchHelper "String"
452 | IType <- ty = matchHelper "Int"
453 | BIType <- ty = matchHelper "Integer"
454 | FlType <- ty = matchHelper "Float"
455 | Forgot <- ty = matchHelper "Forgot"
456 where
457 matchHelper tyName = translateTypeMatch modname var tyName e
459translateCase modname var (SConstCase cst@(BI _) e) =
460 let cond = var ++ ".equals(" ++ translateConstant cst ++ ")" in
461 createIfBlock cond (translateExpression modname e)
463translateCase modname var (SConstCase cst e) =
464 let cond = var ++ " == " ++ translateConstant cst in
465 createIfBlock cond (translateExpression modname e)
467translateCase modname var (SConCase a i name vars e) =
468 let isCon = var ++ " instanceof __IDR__.Con"
469 isI = show i ++ " == " ++ var ++ ".i"
470 params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
471 args = ".apply(this," ++ var ++ ".vars)"
472 f b =
473 "(function("
474 ++ params
475 ++ "){\nreturn " ++ b ++ "\n})" ++ args
476 cond = intercalate " && " [isCon, isI] in
477 createIfBlock cond $ f (translateExpression modname e)
479translateTypeMatch :: String -> String -> String -> SExp -> String
480translateTypeMatch modname var ty exp =
481 let e = translateExpression modname exp in
482 createIfBlock (var
483 ++ " instanceof __IDR__.Type && "
484 ++ var ++ ".type == '"++ ty ++"'") e
487createIfBlock cond e =
488 "if (" ++ cond ++") {\n"
489 ++ "return " ++ e
490 ++ ";\n}"
492createTailcall call =
493 "__IDR__.tailcall(function(){return " ++ call ++ "})"
495translateFunctionCall name vars =
496 concat (intersperse "." $ translateNamespace name)
497 ++ "."
498 ++ translateName name
499 ++ "("
500 ++ intercalate "," (map translateVariableName vars)
501 ++ ")"