git.iko.soy/Idris-dev
on master help sign in
Refactor
commit44f772db1b86777daf95eb5d5a057ac7d1cf4038 authorbe5invis <belleve@typeof.net> dateWed 24 May 2017, 01:24 (9 years ago) parentf5c6f88
11 files changed+1188−873
compare with master
unifiedsplit
idris.cabal+5−1 jsrts/jsbn/jsbn.js → jsrts/jsbn/jsbn-browser.js jsrts/jsbn/jsbn-node.js+1 jstest/tarai.js+298 src/IRTS/CodegenJavaScript.hs+3−1 src/IRTS/JavaScript/AST.hs+247−131 src/IRTS/JavaScript/Codegen.hs+218−474 src/IRTS/JavaScript/JsAST.hs−266 src/IRTS/JavaScript/Name.hs+78 src/IRTS/JavaScript/PrimOp.hs+229 src/IRTS/JavaScript/Specialize.hs+109
idris.cabal+5−1
@@ -47,7 +47,8 @@ Build-type: Custom
4747Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1
4848
4949Data-files: idrisdoc/styles.css
50− jsrts/jsbn/jsbn.js
50+ jsrts/jsbn/jsbn-browser.js
51+ jsrts/jsbn/jsbn-node.js
5152 jsrts/Runtime-common.js
5253 jsrts/Runtime-javascript.js
5354 jsrts/Runtime-node.js
@@ -223,8 +224,11 @@ Library
223224 , IRTS.CodegenJavaScript
224225 , IRTS.Exports
225226 , IRTS.JavaScript.AST
227+ , IRTS.JavaScript.Name
226228 , IRTS.JavaScript.Codegen
227229 , IRTS.JavaScript.LangTransforms
230+ , IRTS.JavaScript.Specialize
231+ , IRTS.JavaScript.PrimOp
228232 , IRTS.Compiler
229233 , IRTS.Defunctionalise
230234 , IRTS.DumpBC
jsrts/jsbn/jsbn.js → jsrts/jsbn/jsbn-browser.jsrenamed

The content is the same.

jsrts/jsbn/jsbn-node.jsnew file+1
@@ -0,0 +1 @@
1+const jsbn = require('jsbn');
jstest/tarai.jsnew file+298
@@ -0,0 +1,298 @@
1+#!/usr/bin/env node
2+"use strict";
3+
4+(function(){
5+
6+const jsbn = require('jsbn')
7+var fs = require('fs');
8+function $partial_5_6$u$io_95_bind(x1, x2, x3, x4, x5){
9+ return (function(x6){
10+ return u$io_95_bind(x1, x2, x3, x4, x5, x6);
11+ });
12+}
13+
14+function $partial_3_4$u$io_95_pure(x1, x2, x3){
15+ return (function(x4){
16+ return u$io_95_pure(x1, x2, x3, x4);
17+ });
18+}
19+
20+function $partial_0_1$u$prim_95__95_toStrInt(){
21+ return (function(x1){
22+ return u$prim_95__95_toStrInt(x1);
23+ });
24+}
25+
26+function $partial_2_3$u$prim_95_write(x1, x2){
27+ return (function(x3){
28+ return u$prim_95_write(x1, x2, x3);
29+ });
30+}
31+
32+function $partial_0_1$q_2$Prelude$Show$t$primNumShow$0(){
33+ return (function(x1){
34+ return q_2$Prelude$Show$t$primNumShow$0(x1);
35+ });
36+}
37+
38+function $partial_0_1$q_2$Prelude$Interactive$t$putStr_39_$0(){
39+ return (function(x1){
40+ return q_2$Prelude$Interactive$t$putStr_39_$0(x1);
41+ });
42+}
43+
44+function $partial_6_7$t$io_95_bind$1(x1, x2, x3, x4, x5, x6){
45+ return (function(x7){
46+ return t$io_95_bind$1(x1, x2, x3, x4, x5, x6, x7);
47+ });
48+}
49+
50+
51+var js_idris_throw2 = function (x){
52+ throw x;
53+}
54+
55+var js_idris_force = function (x){
56+ if(x === undefined || x.js_idris_lazy_calc === undefined){
57+ return x
58+ }else{
59+ if(x.js_idris_lazy_val === undefined){
60+ x.js_idris_lazy_val = x.js_idris_lazy_calc()
61+ }
62+ return x.js_idris_lazy_val
63+ }
64+}
65+
66+var js_idris_systemInfo = function(index) {
67+ var os = require('os')
68+ switch(index) {
69+ case 0:
70+ return "node";
71+ case 1:
72+ return os.platform();
73+ }
74+ return "";
75+}
76+
77+function u$io_95_bind(t$e$0, t$e$1, t$e$2, t$e$3, t$e$4, u$w){
78+ return t$io_95_bind$2(t$e$0, t$e$1, t$e$2, t$e$3, t$e$4, u$w)(t$e$3(u$w));
79+}
80+
81+function u$io_95_pure(t$e$0, t$e$1, t$e$2, u$w){
82+ return t$e$2;
83+}
84+
85+function u$prim_95__95_toStrInt(t$op$0){
86+ return (''+(t$op$0));
87+}
88+
89+function u$prim_95_write(t$e$0, t$e$1, u$w){
90+ return (process.stdout.write((t$e$1)));
91+}
92+
93+function q_1$Main$u$main(){
94+ return q_2$Prelude$Interactive$u$putStr_39_(null, q_2$Prelude$Show$u$primNumShow(null, $partial_0_1$u$prim_95__95_toStrInt(), 0, q_1$Main$u$tarai(11, 5, 0)));
95+}
96+
97+function q_2$Prelude$Show$u$precCon(t$e$0){
98+
99+ if((t$e$0 === 0)) {
100+ return (new jsbn.BigInteger(("0")));
101+ } else {
102+ return (new jsbn.BigInteger(("5")));
103+ }
104+}
105+
106+function q_2$Prelude$Show$u$primNumShow(t$e$0, t$e$1, t$e$2, t$e$3){
107+ const t$in$0 = t$e$1(t$e$3);
108+ let $cg$1 = null;
109+ if(q_2$Prelude$Interfaces$where$q_2$Prelude$Show$impl_1$q_2$Prelude$Interfaces$u$Ord$Prec$meth$u$_62__61_$0(t$e$2, 5)) {
110+ $cg$1 = q_2$Prelude$Show$t$primNumShow$2(t$in$0, t$e$0, t$e$1, t$e$2, t$e$3);
111+ } else {
112+ $cg$1 = false;
113+ }
114+
115+
116+ if($cg$1) {
117+ return ("(" + (t$in$0 + ")"));
118+ } else {
119+ return t$in$0;
120+ }
121+}
122+
123+function q_2$Prelude$Interactive$u$putStr_39_(t$e$0, t$e$1){
124+ return $partial_5_6$u$io_95_bind(null, null, null, $partial_2_3$u$prim_95_write(null, t$e$1), $partial_0_1$q_2$Prelude$Interactive$t$putStr_39_$0());
125+}
126+
127+function q_2$Prelude$Strings$u$strM(t$e$0){
128+ let $cg$1 = null;
129+ if((t$e$0 == "")) {
130+ $cg$1 = false;
131+ } else {
132+ $cg$1 = true;
133+ }
134+
135+
136+ if((q_2$Decidable$Equality$where$q_2$Decidable$Equality$impl_1$q_2$Decidable$Equality$u$DecEq$Bool$meth$u$decEq$0($cg$1, true) === 1)) {
137+ return 0;
138+ } else {
139+ return ({type: 1, $1: t$e$0[0]});
140+ }
141+}
142+
143+function q_1$Main$u$tarai(t$e$0, t$e$1, t$e$2){
144+ let $tco$t$e$1 = t$e$1;
145+ let $tco$t$e$2 = t$e$2;
146+ for(;;) {
147+
148+ if(q_2$Prelude$Interfaces$where$q_2$Prelude$Interfaces$impl_1$q_2$Prelude$Interfaces$u$Ord$Int$meth$u$_60__61_$0(t$e$0, t$e$1)) {
149+ return t$e$1;
150+ } else {
151+ $tco$t$e$1 = q_1$Main$u$tarai(((t$e$1)-(1)|0), t$e$2, t$e$0);
152+ $tco$t$e$2 = q_1$Main$u$tarai(((t$e$2)-(1)|0), t$e$0, t$e$1);
153+ t$e$0 = q_1$Main$u$tarai(((t$e$0)-(1)|0), t$e$1, t$e$2);
154+ t$e$1 = $tco$t$e$1;
155+ t$e$2 = $tco$t$e$2;
156+ }
157+ }
158+}
159+
160+function q_2$Prelude$Interfaces$t$Prelude__Interfaces___64_Prelude__Interfaces__Ord_36_Int_58__33__60__61__58_0_95_lam$0(t$e$0, t$e$1){
161+ return (t$e$0 === t$e$1);
162+}
163+
164+function q_2$Prelude$Interfaces$t$Prelude__Show___64_Prelude__Interfaces__Ord_36_Prec_58__33__62__61__58_0_95_lam$0(t$e$0, t$e$1){
165+ return q_2$Prelude$Interfaces$where$q_2$Prelude$Show$impl_1$q_2$Prelude$Interfaces$u$Eq$Prec$meth$u$_61__61_$0(t$e$0, t$e$1);
166+}
167+
168+function q_2$Prelude$Show$t$primNumShow$0(t$in$1){
169+ return (t$in$1 === "-");
170+}
171+
172+function q_2$Prelude$Interactive$t$putStr_39_$0(t$in$0){
173+ return $partial_3_4$u$io_95_pure(null, null, 0);
174+}
175+
176+function q_2$Prelude$Show$t$primNumShow$1(t$e$0, t$e$1, t$e$2, t$e$3, t$in$0, t$in$2){
177+ return $partial_0_1$q_2$Prelude$Show$t$primNumShow$0();
178+}
179+
180+function q_2$Prelude$Show$t$primNumShow$2(t$in$0, t$e$0, t$e$1, t$e$2, t$e$3){
181+ const $cg$2 = q_2$Prelude$Strings$u$strM(t$in$0);
182+ if(($cg$2.type === 1)) {
183+ return q_2$Prelude$Show$t$primNumShow$1(t$e$0, t$e$1, t$e$2, t$e$3, t$in$0, $cg$2.$1)($cg$2.$1);
184+ } else {
185+ return false;
186+ }
187+}
188+
189+function q_2$Decidable$Equality$where$q_2$Decidable$Equality$impl_1$q_2$Decidable$Equality$u$DecEq$Bool$meth$u$decEq$0(t$e$0, t$e$1){
190+
191+ if(t$e$1) {
192+
193+ if(t$e$0) {
194+ return 0;
195+ } else {
196+ return 1;
197+ }
198+ } else {
199+
200+ if(t$e$0) {
201+ return 1;
202+ } else {
203+ return 0;
204+ }
205+ }
206+}
207+
208+function q_2$Prelude$Interfaces$where$q_2$Prelude$Show$impl_1$q_2$Prelude$Interfaces$u$Eq$Prec$meth$u$_61__61_$0(t$e$0, t$e$1){
209+
210+ return q_2$Prelude$Show$u$precCon(t$e$0).equals(q_2$Prelude$Show$u$precCon(t$e$1));
211+}
212+
213+function q_2$Prelude$Interfaces$where$q_2$Prelude$Interfaces$impl_1$q_2$Prelude$Interfaces$u$Ord$Int$meth$u$_60__61_$0(t$e$0, t$e$1){
214+ let $cg$1 = null;
215+ if((q_2$Prelude$Interfaces$where$q_2$Prelude$Interfaces$impl_1$q_2$Prelude$Interfaces$u$Ord$Int$meth$u$compare$0(t$e$0, t$e$1) === 0)) {
216+ $cg$1 = true;
217+ } else {
218+ $cg$1 = false;
219+ }
220+
221+
222+ if($cg$1) {
223+ return true;
224+ } else {
225+ return q_2$Prelude$Interfaces$t$Prelude__Interfaces___64_Prelude__Interfaces__Ord_36_Int_58__33__60__61__58_0_95_lam$0(t$e$0, t$e$1);
226+ }
227+}
228+
229+function q_2$Prelude$Interfaces$where$q_2$Prelude$Interfaces$impl_1$q_2$Prelude$Interfaces$u$Ord$Int$meth$u$compare$0(t$e$0, t$e$1){
230+
231+ if((t$e$0 === t$e$1)) {
232+ return 1;
233+ } else {
234+
235+ if((t$e$0 < t$e$1)) {
236+ return 0;
237+ } else {
238+ return 2;
239+ }
240+ }
241+}
242+
243+function q_2$Prelude$Interfaces$where$q_2$Prelude$Interfaces$impl_1$q_2$Prelude$Interfaces$u$Ord$Integer$meth$u$compare$0(t$e$0, t$e$1){
244+
245+ if(t$e$0.equals(t$e$1)) {
246+ return 1;
247+ } else {
248+
249+ if(((t$e$0).compareTo((t$e$1)) < 0)) {
250+ return 0;
251+ } else {
252+ return 2;
253+ }
254+ }
255+}
256+
257+function q_2$Prelude$Interfaces$where$q_2$Prelude$Show$impl_1$q_2$Prelude$Interfaces$u$Ord$Prec$meth$u$_62__61_$0(t$e$0, t$e$1){
258+ let $cg$1 = null;
259+ if((q_2$Prelude$Interfaces$where$q_2$Prelude$Show$impl_1$q_2$Prelude$Interfaces$u$Ord$Prec$meth$u$compare$0(t$e$0, t$e$1) === 2)) {
260+ $cg$1 = true;
261+ } else {
262+ $cg$1 = false;
263+ }
264+
265+
266+ if($cg$1) {
267+ return true;
268+ } else {
269+ return q_2$Prelude$Interfaces$t$Prelude__Show___64_Prelude__Interfaces__Ord_36_Prec_58__33__62__61__58_0_95_lam$0(t$e$0, t$e$1);
270+ }
271+}
272+
273+function q_2$Prelude$Interfaces$where$q_2$Prelude$Show$impl_1$q_2$Prelude$Interfaces$u$Ord$Prec$meth$u$compare$0(t$e$0, t$e$1){
274+
275+ return q_2$Prelude$Interfaces$where$q_2$Prelude$Interfaces$impl_1$q_2$Prelude$Interfaces$u$Ord$Integer$meth$u$compare$0(q_2$Prelude$Show$u$precCon(t$e$0), q_2$Prelude$Show$u$precCon(t$e$1));
276+}
277+
278+function t$io_95_bind$0(t$e$0, t$e$1, t$e$2, t$e$3, t$e$4, u$w, t$in$0){
279+ return t$e$4(t$in$0);
280+}
281+
282+function t$runMain$0(){
283+ return js_idris_force(q_1$Main$u$main()(null));
284+}
285+
286+function t$io_95_bind$1(t$e$0, t$e$1, t$e$2, t$e$3, t$e$4, u$w, t$in$0){
287+ return t$io_95_bind$0(t$e$0, t$e$1, t$e$2, t$e$3, t$e$4, u$w, t$in$0)(u$w);
288+}
289+
290+function t$io_95_bind$2(t$e$0, t$e$1, t$e$2, t$e$3, t$e$4, u$w){
291+ return $partial_6_7$t$io_95_bind$1(t$e$0, t$e$1, t$e$2, t$e$3, t$e$4, u$w);
292+}
293+
294+
295+t$runMain$0();
296+
297+
298+}.call(this))
src/IRTS/CodegenJavaScript.hs+3−1
@@ -73,6 +73,7 @@ codegenJavaScript ci =
7373 , initialization = const ""
7474 , writeStrTemplate = "console.log(%0)"
7575 , readStrTemplate = "prompt('Prelude.getLine')"
76+ , jsbnPath = "jsbn/jsbn-browser.js"
7677 , extraRunTime = "Runtime-javascript.js"
7778 }
7879 )
@@ -90,8 +91,9 @@ codegenNode ci =
9091 codegenJs (CGConf { header = "#!/usr/bin/env node\n"
9192 , footer = ""
9293 , initialization = initializationNode
93− , writeStrTemplate = "fs.writeSync(1,%0)"
94+ , writeStrTemplate = "process.stdout.write(%0)"
9495 , readStrTemplate = "js_idris_readStr()"
96+ , jsbnPath = "jsbn/jsbn-node.js"
9597 , extraRunTime = "Runtime-node.js"
9698 }
9799 )
src/IRTS/JavaScript/AST.hs+247−131
@@ -1,15 +1,19 @@
1−{-|
2−Module : IRTS.JavaScript.AST
3−Description : AST for javascrit
4−Copyright :
5−License : BSD3
6−Maintainer : The Idris Community.
7−-}
8−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, PatternGuards #-}
9−
10−module IRTS.JavaScript.AST( JsAST(..)
11− , jsAst2Text
12− ) where
1+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
2+
3+module IRTS.JavaScript.AST
4+ ( JsExpr(..)
5+ , JsStmt(..)
6+ , jsAst2Text
7+ , jsStmt2Text
8+ , jsLazy
9+ , jsCurryLam
10+ , jsCurryApp
11+ , jsAppN
12+ , js_aux_defs
13+ , jsExpr2Stmt
14+ , jsStmt2Expr
15+ , jsSetVar
16+ ) where
1317
1418import Data.Char
1519import Data.Data
@@ -17,39 +21,72 @@ import Data.Text (Text)
1721import qualified Data.Text as T
1822import Numeric
1923
20−data JsAST = JsEmpty
21− | JsNull
22− | JsLambda [Text] JsAST
23− | JsCurryLambda [Text] JsAST
24− | JsFun Text [Text] JsAST
25− | JsReturn JsAST
26− | JsApp Text [JsAST]
27− | JsCurryApp JsAST [JsAST]
28− | JsMethod JsAST Text [JsAST]
29− | JsVar Text
30− | JsSeq JsAST JsAST
31− | JsConst Text JsAST
32− | JsLet Text JsAST
33− | JsSetVar Text JsAST
34− | JsArrayProj JsAST JsAST
35− | JsNum Double
36− | JsInt Int
37− | JsStr String
38− | JsArray [JsAST]
39− | JsSwitchCase JsAST [(JsAST, JsAST)] (Maybe JsAST)
40− | JsError JsAST
41− | JsErrorExp JsAST
42− | JsBinOp Text JsAST JsAST
43− | JsForeign Text [JsAST]
44− | JsWhileTrue JsAST
45− | JsContinue
46− | JsBreak
47− | JsTrue
48− | JsComment Text
49− | JsForce JsAST
50− | JsLazy JsAST
51− deriving (Show, Eq, Data, Typeable)
24+data JsStmt
25+ = JsEmpty
26+ | JsExprStmt JsExpr
27+ | JsFun Text
28+ [Text]
29+ JsStmt
30+ | JsSeq JsStmt
31+ JsStmt
32+ | JsReturn JsExpr
33+ | JsDecVar Text
34+ JsExpr
35+ | JsDecConst Text
36+ JsExpr
37+ | JsDecLet Text
38+ JsExpr
39+ | JsSet JsExpr
40+ JsExpr
41+ | JsIf JsExpr
42+ JsStmt
43+ (Maybe JsStmt)
44+ | JsSwitchCase JsExpr
45+ [(JsExpr, JsStmt)]
46+ (Maybe JsStmt)
47+ | JsError JsExpr
48+ | JsForever JsStmt
49+ | JsContinue
50+ | JsBreak
51+ deriving (Show, Eq, Data, Typeable)
5252
53+data JsExpr
54+ = JsNull
55+ | JsUndefined
56+ | JsThis
57+ | JsLambda [Text]
58+ JsStmt
59+ | JsApp JsExpr
60+ [JsExpr]
61+ | JsPart JsExpr
62+ Text
63+ | JsMethod JsExpr
64+ Text
65+ [JsExpr]
66+ | JsVar Text
67+ | JsArrayProj JsExpr
68+ JsExpr
69+ | JsObj [(Text, JsExpr)]
70+ | JsProp JsExpr
71+ Text
72+ | JsInt Int
73+ | JsBool Bool
74+ | JsInteger Integer
75+ | JsDouble Double
76+ | JsStr String
77+ | JsArray [JsExpr]
78+ | JsErrorExp JsExpr
79+ | JsUniOp Text
80+ JsExpr
81+ | JsBinOp Text
82+ JsExpr
83+ JsExpr
84+ | JsForeign Text
85+ [JsExpr]
86+ | JsB2I JsExpr
87+ | JsComment Text
88+ | JsForce JsExpr
89+ deriving (Show, Eq, Data, Typeable)
5390
5491translateChar :: Char -> String
5592translateChar ch
@@ -82,107 +119,186 @@ translateChar ch
82119 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
83120 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
84121
122+
85123indent :: Text -> Text
86124indent x =
87− let l = T.lines x
88− il = map (\y -> T.replicate 3 " " `T.append` y) l
125+ let l = T.lines x
126+ il = map (\y -> T.replicate 4 " " `T.append` y) l
89127 in T.unlines il
90128
91−curryDef :: [Text] -> JsAST -> Text
92−curryDef [] body =
93− jsAst2Text body
94−curryDef (x:xs) body =
95− T.concat [ "(function", "(", x, "){return "
96− , curryDef xs body
97− , "})"
98− ]
129+jsCurryLam :: [Text] -> JsExpr -> JsExpr
130+jsCurryLam [] body = body
131+jsCurryLam (x:xs) body = JsLambda [x] $ JsReturn $ jsCurryLam xs body
132+
133+jsCurryApp :: JsExpr -> [JsExpr] -> JsExpr
134+jsCurryApp fn [] = fn
135+jsCurryApp fn args = foldl (\ff aa -> JsApp ff [aa]) fn args
99136
137+jsAppN :: Text -> [JsExpr] -> JsExpr
138+jsAppN fn args = JsApp (JsVar fn) args
139+
140+jsSetVar :: Text -> JsExpr -> JsStmt
141+jsSetVar n x = JsSet (JsVar n) x
142+
143+jsStmt2Text :: JsStmt -> Text
144+jsStmt2Text JsEmpty = ""
145+jsStmt2Text (JsExprStmt e) = T.concat [jsAst2Text e, ";"]
146+jsStmt2Text (JsReturn x) = T.concat ["return ", jsAst2Text x, ";"]
147+jsStmt2Text (JsDecVar name exp) =
148+ T.concat ["var ", name, " = ", jsAst2Text exp, ";"]
149+jsStmt2Text (JsDecConst name exp) =
150+ T.concat ["const ", name, " = ", jsAst2Text exp, ";"]
151+jsStmt2Text (JsDecLet name exp) =
152+ T.concat ["let ", name, " = ", jsAst2Text exp, ";"]
153+jsStmt2Text (JsFun name args body) =
154+ T.concat
155+ [ "function "
156+ , name
157+ , "("
158+ , T.intercalate ", " args
159+ , "){\n"
160+ , indent $ jsStmt2Text body
161+ , "}\n"
162+ ]
163+jsStmt2Text (JsIf cond conseq (Just next@(JsIf _ _ _))) =
164+ T.concat
165+ [ "if("
166+ , jsAst2Text cond
167+ , ") {\n"
168+ , indent $ jsStmt2Text conseq
169+ , "} else "
170+ , jsStmt2Text next
171+ ]
172+jsStmt2Text (JsIf cond conseq (Just alt)) =
173+ T.concat
174+ [ "if("
175+ , jsAst2Text cond
176+ , ") {\n"
177+ , indent $ jsStmt2Text conseq
178+ , "} else {\n"
179+ , indent $ jsStmt2Text alt
180+ , "}\n"
181+ ]
182+jsStmt2Text (JsIf cond conseq Nothing) =
183+ T.concat ["if(", jsAst2Text cond, ") {\n", indent $ jsStmt2Text conseq, "}\n"]
184+jsStmt2Text (JsSwitchCase exp l d) =
185+ T.concat
186+ [ "switch("
187+ , jsAst2Text exp
188+ , "){\n"
189+ , indent $ T.concat $ map case2Text l
190+ , indent $ default2Text d
191+ , "}\n"
192+ ]
193+ where
194+ case2Text :: (JsExpr, JsStmt) -> Text
195+ case2Text (x, y) =
196+ T.concat
197+ [ "case "
198+ , jsAst2Text x
199+ , ":\n"
200+ , indent $ T.concat [jsStmt2Text y, ";\nbreak;\n"]
201+ ]
202+ default2Text :: Maybe JsStmt -> Text
203+ default2Text Nothing = ""
204+ default2Text (Just z) =
205+ T.concat ["default:\n", indent $ T.concat [jsStmt2Text z, ";\nbreak;\n"]]
206+jsStmt2Text (JsError t) = T.concat ["throw new Error( ", jsAst2Text t, ");"]
207+jsStmt2Text (JsForever x) =
208+ T.concat ["for(;;) {\n", indent $ jsStmt2Text x, "}\n"]
209+jsStmt2Text JsContinue = "continue;"
210+jsStmt2Text JsBreak = "break;"
211+jsStmt2Text (JsSeq JsEmpty y) = jsStmt2Text y
212+jsStmt2Text (JsSeq x JsEmpty) = jsStmt2Text x
213+jsStmt2Text (JsSeq x y) = T.concat [jsStmt2Text x, "\n", jsStmt2Text y]
214+jsStmt2Text (JsSet term exp) =
215+ T.concat [jsAst2Text term, " = ", jsAst2Text exp, ";"]
100216
101−jsAst2Text :: JsAST -> Text
102−jsAst2Text JsEmpty = ""
217+jsAst2Text :: JsExpr -> Text
103218jsAst2Text JsNull = "null"
219+jsAst2Text JsUndefined = "(void 0)"
220+jsAst2Text JsThis = "this"
104221jsAst2Text (JsLambda args body) =
105− T.concat [ "(function", "(", T.intercalate ", " args , "){"
106− , jsAst2Text body
107− , "})"
108− ]
109−jsAst2Text (JsCurryLambda args body) = curryDef args body
110−jsAst2Text (JsFun name args body) =
111− T.concat [ "var ", name, " = function(", T.intercalate ", " args , "){\n"
112− , indent $ jsAst2Text body
113− , "}\n"
114− ]
115−jsAst2Text (JsReturn x) = T.concat [ "return ", jsAst2Text x]
116−jsAst2Text (JsApp fn args) = T.concat [fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]
117−jsAst2Text (JsCurryApp fn []) = jsAst2Text fn
118−jsAst2Text (JsCurryApp fn args) = T.concat [jsAst2Text fn, "(", T.intercalate ")(" $ map jsAst2Text args, ")"]
222+ T.concat
223+ [ "(function"
224+ , "("
225+ , T.intercalate ", " args
226+ , "){\n"
227+ , indent $ jsStmt2Text body
228+ , "})"
229+ ]
230+jsAst2Text (JsApp fn args) =
231+ T.concat [jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]
119232jsAst2Text (JsMethod obj name args) =
120− T.concat [ jsAst2Text obj
121− , "."
122− , name, "("
123− , T.intercalate ", " $ map jsAst2Text args
124− , ")"
125− ]
233+ T.concat
234+ [ jsAst2Text obj
235+ , "."
236+ , name
237+ , "("
238+ , T.intercalate ", " $ map jsAst2Text args
239+ , ")"
240+ ]
241+jsAst2Text (JsPart obj name) =
242+ T.concat [jsAst2Text obj, "[", T.pack (show name), "]"]
126243jsAst2Text (JsVar x) = x
127−jsAst2Text (JsSeq JsEmpty y) = jsAst2Text y
128−jsAst2Text (JsSeq x JsEmpty) = jsAst2Text x
129−jsAst2Text (JsSeq x y) = T.concat [jsAst2Text x, ";\n", jsAst2Text y]
130−jsAst2Text (JsConst name exp) = T.concat [ "var ", name, " = ", jsAst2Text exp] -- using var instead of const until ES6
131−jsAst2Text (JsLet name exp) = T.concat [ "var ", name, " = ", jsAst2Text exp] -- using var instead of let until ES6
132−jsAst2Text (JsSetVar name exp) = T.concat [ name, " = ", jsAst2Text exp]
133−jsAst2Text (JsArrayProj i exp) = T.concat [ jsAst2Text exp, "[", jsAst2Text i, "]"]
134−jsAst2Text (JsInt i) = T.pack $ show i ++ "|0"
135−jsAst2Text (JsNum d) = T.pack $ show d
244+jsAst2Text (JsObj props) =
245+ T.concat
246+ [ "({"
247+ , T.intercalate
248+ ", "
249+ (map (\(name, val) -> T.concat [name, ": ", jsAst2Text val]) props)
250+ , "})"
251+ ]
252+jsAst2Text (JsProp object name) = T.concat [jsAst2Text object, ".", name]
253+jsAst2Text (JsArrayProj i exp) =
254+ T.concat [jsAst2Text exp, "[", jsAst2Text i, "]"]
255+jsAst2Text (JsInt i) = T.pack $ show i
256+jsAst2Text (JsBool True) = T.pack "true"
257+jsAst2Text (JsBool False) = T.pack "false"
258+jsAst2Text (JsDouble d) = T.pack $ show d
259+jsAst2Text (JsInteger i) = T.pack $ show i
136260jsAst2Text (JsStr s) = "\"" `T.append` T.pack (concatMap translateChar s) `T.append` "\""
137−jsAst2Text (JsArray l) = T.concat [ "[", T.intercalate ", " (map jsAst2Text l), "]"]
138−jsAst2Text (JsSwitchCase exp l d) =
139− T.concat [ "switch(", jsAst2Text exp, "){\n"
140− , indent $ T.concat $ map case2Text l
141− , indent $ default2Text d
142− , "}\n"
143− ]
144−jsAst2Text (JsError t) =
145− T.concat ["throw new Error( ", jsAst2Text t, ")"]
261+jsAst2Text (JsArray l) =
262+ T.concat ["[", T.intercalate ", " (map jsAst2Text l), "]"]
146263jsAst2Text (JsErrorExp t) =
147264 T.concat ["js_idris_throw2(new Error( ", jsAst2Text t, "))"]
148265jsAst2Text (JsBinOp op a1 a2) =
149− T.concat ["(", jsAst2Text a1," ", op, " ",jsAst2Text a2, ")"]
266+ T.concat ["(", jsAst2Text a1, " ", op, " ", jsAst2Text a2, ")"]
267+jsAst2Text (JsUniOp op a) = T.concat ["(", op, jsAst2Text a, ")"]
150268jsAst2Text (JsForeign code args) =
151269 let args_repl c i [] = c
152− args_repl c i (t:r) = args_repl (T.replace ("%" `T.append` T.pack (show i)) t c) (i+1) r
270+ args_repl c i (t:r) =
271+ args_repl (T.replace ("%" `T.append` T.pack (show i)) (T.concat ["(", t, ")"]) c) (i + 1) r
153272 in T.concat ["(", args_repl code 0 (map jsAst2Text args), ")"]
154−jsAst2Text (JsWhileTrue w) =
155− T.concat [ "while(true){\n"
156− , indent $ jsAst2Text w
157− , "}\n"
158− ]
159−jsAst2Text JsContinue =
160− "continue"
161−jsAst2Text JsBreak =
162− "break"
163−jsAst2Text JsTrue =
164− "true"
165−jsAst2Text (JsComment c)=
166− T.concat ["/*",c,"*/"]
167−jsAst2Text (JsLazy e) =
168− T.concat [ "{js_idris_lazy_calc:function(){"
169− , indent $ jsAst2Text e
170− , "}}"
171− ]
172−jsAst2Text (JsForce e) =
173− T.concat ["js_idris_force(", jsAst2Text e, ")"]
174−
175−
176−
177−case2Text :: (JsAST, JsAST) -> Text
178−case2Text (x,y) =
179− T.concat [ "case ", jsAst2Text x, ":\n"
180− , indent $ T.concat [ jsAst2Text y, ";\nbreak;\n"]
181− ]
182−
183−default2Text :: Maybe JsAST -> Text
184−default2Text Nothing = ""
185−default2Text (Just z) =
186− T.concat [ "default:\n"
187− , indent $ T.concat [ jsAst2Text z, ";\nbreak;\n"]
188− ]
273+jsAst2Text (JsB2I x) = jsAst2Text $ JsBinOp "+" x (JsInt 0)
274+jsAst2Text (JsComment c) = T.concat ["/*", c, "*/"]
275+jsAst2Text (JsForce e) = T.concat ["js_idris_force(", jsAst2Text e, ")"]
276+
277+jsLazy :: JsExpr -> JsExpr
278+jsLazy e = JsObj [("js_idris_lazy_calc", (JsLambda [] $ JsReturn e))]
279+
280+throw2 =
281+ T.concat ["var js_idris_throw2 = function (x){\n", " throw x;\n", "}\n"]
282+
283+force =
284+ T.concat
285+ [ "var js_idris_force = function (x){\n"
286+ , " if(x.js_idris_lazy_calc === undefined){\n"
287+ , " return x\n"
288+ , " }else{\n"
289+ , " if(x.js_idris_lazy_val === undefined){\n"
290+ , " x.js_idris_lazy_val = x.js_idris_lazy_calc()\n"
291+ , " }\n"
292+ , " return x.js_idris_lazy_val\n"
293+ , " }\n"
294+ , "}\n"
295+ ]
296+
297+js_aux_defs = T.concat [throw2, force]
298+
299+jsExpr2Stmt :: JsExpr -> JsStmt
300+jsExpr2Stmt = JsExprStmt
301+
302+jsStmt2Expr :: JsStmt -> JsExpr
303+jsStmt2Expr (JsExprStmt x) = x
304+jsStmt2Expr x = JsApp (JsLambda [] x) []
src/IRTS/JavaScript/Codegen.hs+218−474
@@ -16,10 +16,14 @@ import Idris.Core.TT
1616import IRTS.CodegenCommon
1717import IRTS.JavaScript.AST
1818import IRTS.JavaScript.LangTransforms
19+import IRTS.JavaScript.Name
20+import IRTS.JavaScript.PrimOp
21+import IRTS.JavaScript.Specialize
1922import IRTS.Lang
2023import IRTS.LangOpts
2124import IRTS.System
2225
26+import Control.Monad
2327import Control.Monad.Trans.State
2428import Data.List (nub)
2529import Data.Map.Strict (Map)
@@ -41,8 +45,6 @@ import Data.Generics.Uniplate.Data
4145import Data.List
4246import GHC.Generics (Generic)
4347
44−data Partial = Partial Name Int Int deriving (Eq, Ord)
45−
4648data CGStats = CGStats { usedWriteStr :: Bool
4749 , usedReadStr :: Bool
4850 , usedBigInt :: Bool
@@ -57,6 +59,7 @@ data CGConf = CGConf { header :: Text
5759 , initialization :: CGStats -> Text
5860 , writeStrTemplate :: Text
5961 , readStrTemplate :: Text
62+ , jsbnPath :: String
6063 , extraRunTime :: String
6164 }
6265
@@ -96,7 +99,7 @@ codegenJs conf ci =
9699
97100 path <- getIdrisJSRTSDir
98101 jsbn <- if usedBigInt stats
99− then TIO.readFile $ path </> "jsbn/jsbn.js"
102+ then TIO.readFile $ path </> jsbnPath conf
100103 else return ""
101104
102105 runtimeCommon <- TIO.readFile $ path </> "Runtime-common.js"
@@ -119,17 +122,6 @@ codegenJs conf ci =
119122 , footer conf
120123 ]
121124
122−jsName :: Name -> Text
123−jsName n = T.pack $ "idris_" ++ concatMap jschar (showCG n)
124− where jschar x | isAlpha x || isDigit x = [x]
125− | otherwise = "_" ++ show (fromEnum x) ++ "_"
126−
127−jsPartialName :: Partial -> Text
128−jsPartialName (Partial n i j) = T.concat ["partial_", T.pack $ show i, "_", T.pack $ show j, "_" , jsName n]
129−
130−jsTailCallOptimName :: Text -> Text
131−jsTailCallOptimName x = T.concat ["tailCallOptim_cgIdris_", x]
132−
133125doPartials :: Set Partial -> Text
134126doPartials x =
135127 T.intercalate "\n" (map f $ Set.toList x)
@@ -137,8 +129,9 @@ doPartials x =
137129 f p@(Partial n i j) =
138130 let vars1 = map (T.pack . ("x"++) . show) [1..i]
139131 vars2 = map (T.pack . ("x"++) . show) [(i+1)..j]
140− in jsAst2Text $
141− JsFun (jsPartialName p) vars1 $ JsReturn $ JsCurryLambda vars2 (JsApp (jsName n) (map JsVar (vars1 ++ vars2)) )
132+ in jsStmt2Text $
133+ JsFun (jsNamePartial p) vars1 $ JsReturn $
134+ jsCurryLam vars2 (jsAppN (jsName n) (map JsVar (vars1 ++ vars2)) )
142135
143136doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)
144137doCodegen conf defs decls =
@@ -153,17 +146,17 @@ doCodegen conf defs decls =
153146doCodegenDecl :: CGConf -> Map Name LDecl -> LDecl -> (Text, CGStats)
154147doCodegenDecl conf defs (LFun _ n args def) =
155148 let (ast, stats) = cgFun conf defs n args def
156− in (jsAst2Text $ ast, stats)
157−doCodegenDecl conf defs (LConstructor n i sz) =
158− ("", emptyStats)
149+ in (jsStmt2Text $ ast, stats)
150+doCodegenDecl conf defs (LConstructor n i sz) = ("", emptyStats)
159151
160−seqJs :: [JsAST] -> JsAST
152+seqJs :: [JsStmt] -> JsStmt
161153seqJs [] = JsEmpty
162154seqJs (x:xs) = JsSeq x (seqJs xs)
163155
164156
165157data CGBodyState = CGBodyState { defs :: Map Name LDecl
166158 , lastIntName :: Int
159+ , reWrittenNames :: Map.Map Name JsExpr
167160 , currentFnNameAndArgs :: (Text, [Text])
168161 , usedArgsTailCallOptim :: Set (Text, Text)
169162 , isTailRec :: Bool
@@ -180,7 +173,7 @@ getNewCGName =
180173 st <- get
181174 let v = lastIntName st + 1
182175 put $ st {lastIntName = v}
183− return $ T.pack $ "cgIdris_" ++ show v
176+ return $ jsNameGenerated v
184177
185178addPartial :: Partial -> State CGBodyState ()
186179addPartial p =
@@ -194,12 +187,12 @@ getNewCGNames :: Int -> State CGBodyState [Text]
194187getNewCGNames n =
195188 mapM (\_ -> getNewCGName) [1..n]
196189
197−getConsId :: Name -> State CGBodyState Int
190+getConsId :: Name -> State CGBodyState (Int, Int)
198191getConsId n =
199192 do
200193 st <- get
201194 case Map.lookup n (defs st) of
202− Just (LConstructor _ conId _) -> pure conId
195+ Just (LConstructor _ conId arity) -> pure (conId, arity)
203196 _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."
204197
205198getArgList :: Name -> State CGBodyState (Maybe [Name])
@@ -216,26 +209,15 @@ data BodyResTarget = ReturnBT
216209 | DecConstBT Text
217210 | GetExpBT
218211
219−replaceVarsByProj :: JsAST -> Map Text Int -> JsAST -> JsAST
220−replaceVarsByProj n d z =
221− transform f z
222− where
223− f :: JsAST -> JsAST
224− f (JsVar x) =
225− case Map.lookup x d of
226− Nothing -> (JsVar x)
227− Just i -> JsArrayProj (JsInt i) n
228− f x = x
229−
230−cgFun :: CGConf -> Map Name LDecl -> Name -> [Name] -> LExp -> (JsAST, CGStats)
231−cgFun cnf dfs n args def =
232− let
233− fnName = jsName n
234− argNames = map jsName args
235− ((decs, res),st) = runState
212+cgFun :: CGConf -> Map Name LDecl -> Name -> [Name] -> LExp -> (JsStmt, CGStats)
213+cgFun cnf dfs n args def = do
214+ let fnName = jsName n
215+ let argNames = map jsName args
216+ let ((decs, res),st) = runState
236217 (cgBody ReturnBT def)
237218 (CGBodyState { defs=dfs
238219 , lastIntName = 0
220+ , reWrittenNames = Map.empty
239221 , currentFnNameAndArgs = (fnName, argNames)
240222 , usedArgsTailCallOptim = Set.empty
241223 , isTailRec = False
@@ -246,19 +228,16 @@ cgFun cnf dfs n args def =
246228 , partialApps = Set.empty
247229 }
248230 )
249− body = if isTailRec st then
250− JsSeq
251− (declareUsedOptimArgs $ usedArgsTailCallOptim st)
252− (JsWhileTrue ((seqJs decs) `JsSeq` res))
253− else (seqJs decs) `JsSeq` res
254− in (JsFun fnName argNames $ body, CGStats { usedWriteStr = usedWrite st
255− , partialApplications = partialApps st
256− , usedBigInt = usedITBig st
257− , usedReadStr = usedRead st
258− }
259− )
260−
261−getSwitchJs :: JsAST -> [LAlt] -> JsAST
231+ let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res
232+ let fn = JsFun fnName argNames body
233+ let state' = CGStats { usedWriteStr = usedWrite st
234+ , partialApplications = partialApps st
235+ , usedBigInt = usedITBig st
236+ , usedReadStr = usedRead st
237+ }
238+ (fn, state')
239+
240+getSwitchJs :: JsExpr -> [LAlt] -> JsExpr
262241getSwitchJs x alts =
263242 if any conCase alts then JsArrayProj (JsInt 0) x
264243 else if any constBigIntCase alts then JsForeign "%0.toString()" [x]
@@ -268,48 +247,75 @@ getSwitchJs x alts =
268247 constBigIntCase (LConstCase (BI _) _) = True
269248 constBigIntCase _ = False
270249
271−addRT :: BodyResTarget -> JsAST -> JsAST
250+addRT :: BodyResTarget -> JsExpr -> JsStmt
272251addRT ReturnBT x = JsReturn x
273−addRT (DecBT n) x = JsLet n x
274−addRT (SetBT n) x = JsSetVar n x
275−addRT (DecConstBT n) x = JsConst n x
276−addRT GetExpBT x = x
252+addRT (DecBT n) x = JsDecLet n x
253+addRT (DecConstBT n) x = JsDecConst n x
254+addRT (SetBT n) x = JsSet (JsVar n) x
255+addRT GetExpBT x = JsExprStmt x
277256
278−declareUsedOptimArgs :: Set (Text, Text) -> JsAST
279−declareUsedOptimArgs x = seqJs $ map (\(x,y) -> JsLet x (JsVar y) ) (Set.toList x)
257+declareUsedOptimArgs :: Set (Text, Text) -> JsStmt
258+declareUsedOptimArgs x = seqJs $ map (\(x,y) -> JsDecLet x (JsVar y) ) (Set.toList x)
280259
281−tailCallOptimRefreshArgs :: [(Text, JsAST)] -> Set Text -> ((JsAST, JsAST), Set (Text, Text))
260+tailCallOptimRefreshArgs :: [(Text, JsExpr)] -> Set Text -> ((JsStmt, JsStmt), Set (Text, Text))
282261tailCallOptimRefreshArgs [] s = ((JsEmpty, JsEmpty), Set.empty)
283262tailCallOptimRefreshArgs ((n,x):r) s =
284263 let ((y1,y2), y3) = tailCallOptimRefreshArgs r (Set.insert n s) --
285264 in if Set.null $ (Set.fromList [ z | z <- universeBi x ]) `Set.intersection` s then
286− ((y1, JsSetVar n x `JsSeq` y2), y3)
265+ ((y1, jsSetVar n x `JsSeq` y2), y3)
287266 else
288267 let n' = jsTailCallOptimName n
289− in ((JsSetVar n' x `JsSeq` y1, JsSetVar n (JsVar n') `JsSeq` y2), Set.insert (n',n) y3)
290−
291−
292−cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsAST], JsAST)
293−cgBody rt (LV (Glob n)) =
268+ in ((jsSetVar n' x `JsSeq` y1, jsSetVar n (JsVar n') `JsSeq` y2), Set.insert (n',n) y3)
269+
270+cgName :: Name -> State CGBodyState JsExpr
271+cgName b = do
272+ st <- get
273+ case Map.lookup b (reWrittenNames st) of
274+ Just e -> pure e
275+ _ -> pure $ JsVar $ jsName b
276+
277+cgBody :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
278+cgBody rt expr =
279+ case expr of
280+ (LCase _ (LOp oper [x, y]) [LConstCase (I 0) (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
281+ | (ff == qualifyN "Prelude.Bool" "False" &&
282+ tt == qualifyN "Prelude.Bool" "True") ->
283+ case (Map.lookup oper primDB) of
284+ Just (useBigInt, pti, combinator) | pti == PTBool -> do
285+ z <- mapM (cgBody GetExpBT) [x, y]
286+ when useBigInt setUsedITBig
287+ let res = jsPrimCoerce pti PTBool $ combinator $ map (jsStmt2Expr . snd) z
288+ pure $ (concat $ map fst z, addRT rt res)
289+ _ -> cgBody' rt expr
290+ (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq])
291+ | (ff == qualifyN "Prelude.Bool" "False" &&
292+ tt == qualifyN "Prelude.Bool" "True") ->
293+ cgBody' rt $ LCase f e [LConCase nt tt [] conseq, LConCase nf ff [] alt]
294+ expr -> cgBody' rt expr
295+
296+cgBody' :: BodyResTarget -> LExp -> State CGBodyState ([JsStmt], JsStmt)
297+cgBody' rt (LV (Glob n)) =
294298 do
295299 argsFn <- getArgList n
296300 case argsFn of
297− Just [] ->
298− pure $ ([], addRT rt $ JsApp (jsName n) [])
301+ Just [] -> do
302+ n' <- cgName n
303+ pure $ ([], addRT rt n')
299304 Just a ->
300305 do
301− let part = Partial n 0 (length a)
306+ let part = Partial n 0 (length a)
302307 addPartial part
303− pure ([], addRT rt $ JsApp (jsPartialName part) [])
304− Nothing ->
305− pure $ ([], addRT rt $ JsVar $ jsName n)
306−cgBody rt (LApp tailcall (LV (Glob fn)) args) =
308+ pure ([], addRT rt $ jsAppN (jsNamePartial part) [])
309+ Nothing -> do
310+ n' <- cgName n
311+ pure $ ([], addRT rt n')
312+cgBody' rt (LApp tailcall (LV (Glob fn)) args) =
307313 do
308314 let fname = jsName fn
309315 st <- get
310316 let (currFn, argN) = currentFnNameAndArgs st
311317 z <- mapM (cgBody GetExpBT) args
312− let argVals = map snd z
318+ let argVals = map (jsStmt2Expr . snd) z
313319 let preDecs = concat $ map fst z
314320 case (fname == currFn && (length args) == (length argN), rt) of
315321 (True, ReturnBT) ->
@@ -323,81 +329,86 @@ cgBody rt (LApp tailcall (LV (Glob fn)) args) =
323329 argsFn <- getArgList fn
324330 case argsFn of
325331 Nothing ->
326− pure (preDecs, addRT rt $ JsCurryApp (JsVar fname) argVals )
332+ pure (preDecs, addRT rt $ jsCurryApp (JsVar fname) argVals )
327333 Just agFn ->
328334 do
329335 let lenAgFn = length agFn
330336 let lenArgs = length args
331337 case compare lenAgFn lenArgs of
332338 EQ ->
333− pure (preDecs, addRT rt $ JsApp fname argVals)
339+ pure (preDecs, addRT rt $ jsAppN fname argVals)
334340 LT ->
335− pure (preDecs, addRT rt $ JsCurryApp (JsApp fname (take lenAgFn argVals )) (drop lenAgFn argVals) )
341+ pure (preDecs, addRT rt $ jsCurryApp (jsAppN fname (take lenAgFn argVals)) (drop lenAgFn argVals) )
336342 GT ->
337343 do
338344 let part = Partial fn lenArgs lenAgFn
339345 addPartial part
340− pure (preDecs, addRT rt $ JsApp (jsPartialName part) argVals )
346+ pure (preDecs, addRT rt $ jsAppN (jsNamePartial part) argVals )
341347
342−cgBody rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
343−cgBody rt (LLazyApp n args) =
348+cgBody' rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)
349+cgBody' rt (LLazyApp n args) =
344350 do
345351 (d,v) <- cgBody ReturnBT (LApp False (LV (Glob n)) args)
346− pure ([], addRT rt $ JsLazy $ JsSeq (seqJs d) v)
347−cgBody rt (LForce e) =
352+ pure ([], addRT rt $ jsLazy $ jsStmt2Expr $ JsSeq (seqJs d) v)
353+cgBody' rt (LForce e) =
348354 do
349355 (d,v) <- cgBody GetExpBT e
350− pure (d, addRT rt $ JsForce v)
351−cgBody rt (LLet n v sc) =
356+ pure (d, addRT rt $ JsForce $ jsStmt2Expr v)
357+cgBody' rt (LLet n v sc) =
352358 do
353359 (d1, v1) <- cgBody (DecConstBT $ jsName n) v
354360 (d2, v2) <- cgBody rt sc
355− pure $ ((d1 ++ v1 : d2), v2 )
356−cgBody rt (LProj e i) =
361+ pure $ ((d1 ++ v1 : d2), v2)
362+cgBody' rt (LProj e i) =
357363 do
358364 (d, v) <- cgBody GetExpBT e
359− pure $ (d, addRT rt $ JsArrayProj (JsInt $ i+1) $ v)
360−cgBody rt (LCon _ conId n args) =
365+ pure $ (d, addRT rt $ JsArrayProj (JsInt $ i+1) $ jsStmt2Expr v)
366+cgBody' rt (LCon _ conId n args) =
361367 do
362368 z <- mapM (cgBody GetExpBT) args
363− pure $ (concat $ map fst z, addRT rt $ JsArray (JsInt conId : map snd z))
364−cgBody rt (LCase _ e alts) =
365− do
366− (d,v) <- cgBody GetExpBT e
367− resName <- getNewCGName
368− swName <- getNewCGName
369− (altsJs,def) <- cgAlts rt resName (JsVar swName) alts
370− let decSw = JsConst swName v
371− let sw = JsSwitchCase (getSwitchJs (JsVar swName) alts) altsJs def
372− case rt of
373− ReturnBT ->
374− pure (d ++ [decSw], sw)
375− (DecBT nvar) ->
376− pure (d ++ [decSw, JsLet nvar JsNull], sw)
377− (SetBT nvar) ->
378− pure (d ++ [decSw], sw)
379− GetExpBT ->
380− pure (d ++ [decSw, JsLet resName JsNull, sw], JsVar resName)
381− (DecConstBT nvar) ->
382− pure (d ++ [decSw, JsLet nvar JsNull], sw)
383−cgBody rt (LConst c) =
369+ con <- formCon n (map (jsStmt2Expr . snd) z)
370+ pure $ (concat $ map fst z, addRT rt con)
371+cgBody' rt (LCase _ e alts) = do
372+ (d, v) <- cgBody GetExpBT e
373+ resName <- getNewCGName
374+ (decSw, entry) <-
375+ case (all altHasNoProj alts && length alts <= 2, v) of
376+ (True, _) -> pure (JsEmpty, jsStmt2Expr v)
377+ (False, JsExprStmt (JsVar n)) -> pure (JsEmpty, jsStmt2Expr v)
378+ _ -> do
379+ swName <- getNewCGName
380+ pure (JsDecConst swName $ jsStmt2Expr v, JsVar swName)
381+ sw' <- cgIfTree rt resName entry alts
382+ let sw =
383+ case sw' of
384+ (Just x) -> x
385+ Nothing -> JsExprStmt JsNull
386+ case rt of
387+ ReturnBT -> pure (d ++ [decSw], sw)
388+ (DecBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)
389+ (DecConstBT nvar) -> pure (d ++ [decSw, JsDecLet nvar JsNull], sw)
390+ (SetBT nvar) -> pure (d ++ [decSw], sw)
391+ GetExpBT ->
392+ pure
393+ (d ++ [decSw, JsDecLet resName JsNull, sw], JsExprStmt $ JsVar resName)
394+cgBody' rt (LConst c) =
384395 do
385396 cst <- cgConst c
386397 pure ([], (addRT rt) $ cst)
387−cgBody rt (LOp op args) =
398+cgBody' rt (LOp op args) =
388399 do
389400 z <- mapM (cgBody GetExpBT) args
390− res <- cgOp op (map snd z)
401+ res <- cgOp op (map (jsStmt2Expr . snd) z)
391402 pure $ (concat $ map fst z, addRT rt $ res)
392−cgBody rt LNothing = pure ([], addRT rt JsNull)
393−cgBody rt (LError x) = pure ([], JsError $ JsStr x)
394−cgBody rt x@(LForeign dres (FStr code) args ) =
403+cgBody' rt LNothing = pure ([], addRT rt JsNull)
404+cgBody' rt (LError x) = pure ([], JsError $ JsStr x)
405+cgBody' rt x@(LForeign dres (FStr code) args ) =
395406 do
396407 z <- mapM (cgBody GetExpBT) (map snd args)
397− jsArgs <- sequence $ map cgForeignArg (zip (map fst args) (map snd z))
408+ jsArgs <- sequence $ map cgForeignArg (zip (map fst args) (map (jsStmt2Expr . snd) z))
398409 jsDres <- cgForeignRes dres $ JsForeign (T.pack code) jsArgs
399410 pure $ (concat $ map fst z, addRT rt $ jsDres)
400−cgBody _ x = error $ "Instruction " ++ show x ++ " not compilable yet"
411+cgBody' _ x = error $ "Instruction " ++ show x ++ " not compilable yet"
401412
402413altsRT :: Text -> BodyResTarget -> BodyResTarget
403414altsRT rn ReturnBT = ReturnBT
@@ -406,36 +417,85 @@ altsRT rn (SetBT n) = SetBT n
406417altsRT rn (DecConstBT n) = SetBT n
407418altsRT rn GetExpBT = SetBT rn
408419
409−cgAlts :: BodyResTarget -> Text -> JsAST -> [LAlt] -> State CGBodyState ([(JsAST, JsAST)], Maybe JsAST)
410−cgAlts rt resName scrvar ((LConstCase t exp):r) =
411− do
412− (d, v) <- cgBody (altsRT resName rt) exp
413− (ar, def) <- cgAlts rt resName scrvar r
414− cst <- case t of
415− BI _ ->
416− do
417− setUsedITBig
418− c' <- cgConst t
419− pure $ JsForeign "%0.toString()" [c']
420− _ -> cgConst t
421− pure ((cst, JsSeq (seqJs d) v) : ar, def)
422−cgAlts rt resName scrvar ((LDefaultCase exp):r) =
423− do
424− (d, v) <- cgBody (altsRT resName rt) exp
425− pure ([], Just $ JsSeq (seqJs d) v)
426−cgAlts rt resName scrvar ((LConCase _ n args exp):r) =
427− do
428− (d, v) <- cgBody (altsRT resName rt) exp
429− (ar, def) <- cgAlts rt resName scrvar r
430− conId <- getConsId n
431− let replace = replaceVarsByProj scrvar (Map.fromList $ zip (map jsName args) [1..])
432− let branchBody = JsSeq (seqJs $ map replace d) (replace v)
433− pure ((JsInt conId, branchBody) : ar, def)
434−cgAlts _ _ _ [] =
435− pure ([],Nothing)
436−
437−
438−cgForeignArg :: (FDesc, JsAST) -> State CGBodyState JsAST
420+altHasNoProj :: LAlt -> Bool
421+altHasNoProj (LConCase _ _ args _) = args == []
422+altHasNoProj _ = True
423+
424+formCon :: Name -> [JsExpr] -> State CGBodyState JsExpr
425+formCon n args = do
426+ case specialCased n of
427+ Just (ctor, test, match) -> pure $ ctor args
428+ Nothing -> do
429+ (conId, arity) <- getConsId n
430+ if (arity > 0)
431+ then pure $
432+ JsObj $
433+ (T.pack "type", JsInt conId) :
434+ zip (map (\i -> T.pack $ "$" ++ show i) [1 ..]) args
435+ else pure $ JsInt conId
436+
437+formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
438+formConTest n x = do
439+ case specialCased n of
440+ Just (ctor, test, match) -> pure $ test x
441+ Nothing -> do
442+ (conId, arity) <- getConsId n
443+ if (arity > 0)
444+ then pure $ JsBinOp "===" (JsProp x (T.pack "type")) (JsInt conId)
445+ else pure $ JsBinOp "===" x (JsInt conId)
446+
447+formProj :: Name -> JsExpr -> Int -> JsExpr
448+formProj n v i =
449+ case specialCased n of
450+ Just (ctor, test, proj) -> proj v i
451+ Nothing -> JsProp v (T.pack $ "$" ++ show i)
452+
453+smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
454+smartif cond conseq (Just alt) = JsIf cond conseq (Just alt)
455+smartif cond conseq Nothing = conseq
456+
457+cgIfTree :: BodyResTarget
458+ -> Text
459+ -> JsExpr
460+ -> [LAlt]
461+ -> State CGBodyState (Maybe JsStmt)
462+cgIfTree _ _ _ [] = pure Nothing
463+cgIfTree rt resName scrvar ((LConstCase t exp):r) = do
464+ (d, v) <- cgBody (altsRT resName rt) exp
465+ alternatives <- cgIfTree rt resName scrvar r
466+ test <- case t of
467+ BI _ -> do
468+ t' <- cgConst t
469+ cgOp (LPlus (ATInt ITBig)) [scrvar, t']
470+ _ -> do
471+ t' <- cgConst t
472+ pure $ JsBinOp "===" scrvar t'
473+ pure $ Just $
474+ smartif test (JsSeq (seqJs d) v) alternatives
475+cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do
476+ (d, v) <- cgBody (altsRT resName rt) exp
477+ pure $ Just $ JsSeq (seqJs d) v
478+cgIfTree rt resName scrvar ((LConCase _ n args exp):r) = do
479+ alternatives <- cgIfTree rt resName scrvar r
480+ test <- formConTest n scrvar
481+ st <- get
482+ let rwn = reWrittenNames st
483+ put $
484+ st
485+ { reWrittenNames =
486+ foldl
487+ (\m (n, j) -> Map.insert n (formProj n scrvar j) m)
488+ rwn
489+ (zip args [1 ..])
490+ }
491+ (d, v) <- cgBody (altsRT resName rt) exp
492+ st1 <- get
493+ put $ st1 {reWrittenNames = rwn}
494+ let branchBody = JsSeq (seqJs d) v
495+ pure $ Just $ smartif test branchBody alternatives
496+
497+
498+cgForeignArg :: (FDesc, JsExpr) -> State CGBodyState JsExpr
439499cgForeignArg (FApp (UN "JS_IntT") _, v) = pure v
440500cgForeignArg (FCon (UN "JS_Str"), v) = pure v
441501cgForeignArg (FCon (UN "JS_Ptr"), v) = pure v
@@ -446,14 +506,14 @@ cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnBa
446506cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO") [_,_, b]]], f) =
447507 do
448508 jsx <- cgForeignArg (a, JsVar "x")
449− jsres <- cgForeignRes b $ JsCurryApp (JsCurryApp f [jsx]) [JsNull]
509+ jsres <- cgForeignRes b $ jsCurryApp (jsCurryApp f [jsx]) [JsNull]
450510 pure $ JsLambda ["x"] $ JsReturn jsres
451511cgForeignArg (desc, _) =
452512 do
453513 st <- get
454514 error $ "Foreign arg type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)
455515
456−cgForeignRes :: FDesc -> JsAST -> State CGBodyState JsAST
516+cgForeignRes :: FDesc -> JsExpr -> State CGBodyState JsExpr
457517cgForeignRes (FApp (UN "JS_IntT") _) x = pure x
458518cgForeignRes (FCon (UN "JS_Unit")) x = pure x
459519cgForeignRes (FCon (UN "JS_Str")) x = pure x
@@ -468,7 +528,7 @@ setUsedITBig :: State CGBodyState ()
468528setUsedITBig = modify (\s -> s {usedITBig = True})
469529
470530
471−cgConst :: Const -> State CGBodyState JsAST
531+cgConst :: Const -> State CGBodyState JsExpr
472532cgConst (I i) = pure $ JsInt i
473533cgConst (BI i) =
474534 do
@@ -476,7 +536,7 @@ cgConst (BI i) =
476536 pure $ JsForeign "new jsbn.BigInteger(%0)" [JsStr $ show i]
477537cgConst (Ch c) = pure $ JsStr [c]
478538cgConst (Str s) = pure $ JsStr s
479−cgConst (Fl f) = pure $ JsNum f
539+cgConst (Fl f) = pure $ JsDouble f
480540cgConst (B8 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFF") []
481541cgConst (B16 x) = pure $ JsForeign (T.pack $ show x ++ " & 0xFFFF") []
482542cgConst (B32 x) = pure $ JsForeign (T.pack $ show x ++ "|0" ) []
@@ -487,327 +547,10 @@ cgConst (B64 x) =
487547cgConst x | isTypeConst x = pure $ JsInt 0
488548cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
489549
490−jsB2I :: JsAST -> JsAST
550+jsB2I :: JsExpr -> JsExpr
491551jsB2I x = JsForeign "%0 ? 1|0 : 0|0" [x]
492552
493−cgOp :: PrimFn -> [JsAST] -> State CGBodyState JsAST
494−cgOp (LPlus ATFloat) [l, r] = pure $ JsBinOp "+" l r
495−cgOp (LPlus (ATInt ITChar)) [l, r] = pure $ JsForeign "String.fromCharCode(%0.charCodeAt(0) + %1.charCodeAt(0))" [l,r]
496−cgOp (LPlus (ATInt ITNative)) [l, r] = pure $ JsForeign "%0+%1|0" [l,r]
497−cgOp (LPlus (ATInt (ITFixed IT8))) [l, r] = pure $ JsForeign "%0 + %1 & 0xFF" [l,r]
498−cgOp (LPlus (ATInt (ITFixed IT16))) [l, r] = pure $ JsForeign "%0 + %1 & 0xFFFF" [l,r]
499−cgOp (LPlus (ATInt (ITFixed IT32))) [l, r] = pure $ JsForeign "%0+%1|0" [l,r]
500−cgOp (LPlus (ATInt ITBig)) [l, r] =
501− do
502− setUsedITBig
503− pure $ JsMethod l "add" [r]
504−cgOp (LPlus (ATInt (ITFixed IT64))) [l, r] =
505− do
506− setUsedITBig
507− pure $ JsForeign "%0.add(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
508−cgOp (LMinus ATFloat) [l, r] = pure $ JsBinOp "-" l r
509−cgOp (LMinus (ATInt ITChar)) [l, r] = pure $ JsForeign "String.fromCharCode(%0.charCodeAt(0) - %1.charCodeAt(0))" [l,r]
510−cgOp (LMinus (ATInt ITNative)) [l, r] = pure $ JsForeign "%0-%1|0" [l,r]
511−cgOp (LMinus (ATInt (ITFixed IT8))) [l, r] = pure $ JsForeign "%0 - %1 & 0xFF" [l,r]
512−cgOp (LMinus (ATInt (ITFixed IT16))) [l, r] = pure $ JsForeign "%0 - %1 & 0xFFFF" [l,r]
513−cgOp (LMinus (ATInt (ITFixed IT32))) [l, r] = pure $ JsForeign "%0-%1|0" [l,r]
514−cgOp (LMinus (ATInt ITBig)) [l, r] =
515− do
516− setUsedITBig
517− pure $ JsMethod l "subtract" [r]
518−cgOp (LMinus (ATInt (ITFixed IT64))) [l, r] =
519− do
520− setUsedITBig
521− pure $ JsForeign "%0.subtract(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
522−cgOp (LTimes ATFloat) [l, r] = pure $ JsBinOp "*" l r
523−cgOp (LTimes (ATInt ITChar)) [l, r] = pure $ JsForeign "String.fromCharCode(%0.charCodeAt(0) * %1.charCodeAt(0))" [l,r]
524−cgOp (LTimes (ATInt ITNative)) [l, r] = pure $ JsForeign "%0*%1|0" [l,r]
525−cgOp (LTimes (ATInt (ITFixed IT8))) [l, r] = pure $ JsForeign "%0 * %1 & 0xFF" [l,r]
526−cgOp (LTimes (ATInt (ITFixed IT16))) [l, r] = pure $ JsForeign "%0 * %1 & 0xFFFF" [l,r]
527−cgOp (LTimes (ATInt (ITFixed IT32))) [l, r] = pure $ JsForeign "%0*%1|0" [l,r]
528−cgOp (LTimes (ATInt ITBig)) [l, r] =
529− do
530− setUsedITBig
531− pure $ JsMethod l "multiply" [r]
532−cgOp (LTimes (ATInt (ITFixed IT64))) [l, r] =
533− do
534− setUsedITBig
535− pure $ JsForeign "%0.multiply(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
536−cgOp (LUDiv (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 / %1" [l,r]
537−cgOp (LUDiv (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 / %1" [l,r]
538−cgOp (LUDiv (ITFixed IT32)) [l, r] = pure $ JsForeign "(%0>>>0) / (%1>>>0) |0" [l,r]
539−cgOp (LUDiv (ITFixed IT64)) [l, r] =
540− do
541− setUsedITBig
542− pure $ JsForeign "%0.divide(%1)" [l,r]
543−cgOp (LSDiv ATFloat) [l,r] = pure $ JsBinOp "/" l r
544−cgOp (LSDiv (ATInt (ITFixed IT8))) [l, r] = pure $ JsForeign "%0 / %1" [l,r]
545−cgOp (LSDiv (ATInt (ITFixed IT16))) [l, r] = pure $ JsForeign "%0 / %1" [l,r]
546−cgOp (LSDiv (ATInt (ITFixed IT32))) [l, r] = pure $ JsForeign "%0 / %1 |0" [l,r]
547−cgOp (LSDiv (ATInt (ITFixed IT64))) [l, r] =
548− do
549− setUsedITBig
550− pure $ JsForeign "%0.divide(%1)" [l,r]
551−cgOp (LSDiv (ATInt ITNative)) [l,r] = pure $ JsForeign "%0/%1|0" [l, r]
552−cgOp (LSDiv (ATInt ITBig)) [l,r] =
553− do
554− setUsedITBig
555− pure $ JsMethod l "divide" [r]
556−cgOp (LURem (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 % %1" [l,r]
557−cgOp (LURem (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 % %1" [l,r]
558−cgOp (LURem (ITFixed IT32)) [l, r] = pure $ JsForeign "(%0>>>0) % (%1>>>0) |0" [l,r]
559−cgOp (LURem (ITFixed IT64)) [l,r] =
560− do
561− setUsedITBig
562− pure $ JsMethod l "remainder" [r]
563−cgOp (LSRem ATFloat) [l,r] = pure $ JsBinOp "%" l r
564−cgOp (LSRem (ATInt ITNative)) [l,r] = pure $ JsForeign "%0 % %1 |0" [l,r]
565−cgOp (LSRem (ATInt (ITFixed IT8))) [l, r] = pure $ JsForeign "%0 % %1" [l,r]
566−cgOp (LSRem (ATInt (ITFixed IT16))) [l, r] = pure $ JsForeign "%0 % %1" [l,r]
567−cgOp (LSRem (ATInt (ITFixed IT32))) [l, r] = pure $ JsForeign "%0 % %1 |0" [l,r]
568−cgOp (LSRem (ATInt (ITFixed IT64))) [l, r] =
569− do
570− setUsedITBig
571− pure $ JsMethod l "remainder" [r]
572−cgOp (LSRem (ATInt ITBig)) [l,r] =
573− do
574− setUsedITBig
575− pure $ JsMethod l "remainder" [r]
576−cgOp (LAnd ITNative) [l, r] = pure $ JsForeign "%0 & %1" [l,r]
577−cgOp (LAnd (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 & %1" [l,r]
578−cgOp (LAnd (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 & %1" [l,r]
579−cgOp (LAnd (ITFixed IT32)) [l, r] = pure $ JsForeign "%0 & %1" [l,r]
580−cgOp (LAnd (ITFixed IT64)) [l,r] =
581− do
582− setUsedITBig
583− pure $ JsMethod l "and" [r]
584−cgOp (LAnd ITBig) [l,r] =
585− do
586− setUsedITBig
587− pure $ JsMethod l "and" [r]
588−cgOp (LOr ITNative) [l, r] = pure $ JsForeign "%0 | %1" [l,r]
589−cgOp (LOr (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 | %1" [l,r]
590−cgOp (LOr (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 | %1" [l,r]
591−cgOp (LOr (ITFixed IT32)) [l, r] = pure $ JsForeign "%0 | %1" [l,r]
592−cgOp (LOr (ITFixed IT64)) [l,r] =
593− do
594− setUsedITBig
595− pure $ JsMethod l "or" [r]
596−cgOp (LOr ITBig) [l,r] =
597− do
598− setUsedITBig
599− pure $ JsMethod l "or" [r]
600−cgOp (LXOr ITNative) [l, r] = pure $ JsForeign "%0 ^ %1" [l,r]
601−cgOp (LXOr (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 ^ %1" [l,r]
602−cgOp (LXOr (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 ^ %1" [l,r]
603−cgOp (LXOr (ITFixed IT32)) [l, r] = pure $ JsForeign "%0 ^ %1" [l,r]
604−cgOp (LXOr (ITFixed IT64)) [l,r] =
605− do
606− setUsedITBig
607− pure $ JsMethod l "xor" [r]
608−cgOp (LXOr ITBig) [l,r] =
609− do
610− setUsedITBig
611− pure $ JsMethod l "xor" [r]
612−cgOp (LSHL ITNative) [l, r] = pure $ JsForeign "%0 << %1 |0" [l,r]
613−cgOp (LSHL (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 << %1 & 0xFF" [l,r]
614−cgOp (LSHL (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 << %1 & 0xFFFF" [l,r]
615−cgOp (LSHL (ITFixed IT32)) [l, r] = pure $ JsForeign "%0 << %1 |0" [l,r]
616−cgOp (LSHL (ITFixed IT64)) [l, r] =
617− do
618− setUsedITBig
619− pure $ JsForeign "%0.shiftLeft(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
620−cgOp (LSHL ITBig) [l,r] =
621− do
622− setUsedITBig
623− pure $ JsMethod l "shiftLeft" [r]
624−cgOp (LLSHR ITNative) [l, r] = pure $ JsForeign "%0 >> %1 |0" [l,r]
625−cgOp (LLSHR (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 >> %1" [l,r]
626−cgOp (LLSHR (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 >> %1" [l,r]
627−cgOp (LLSHR (ITFixed IT32)) [l, r] = pure $ JsForeign "%0 >> %1|0" [l,r]
628−cgOp (LLSHR (ITFixed IT64)) [l, r] =
629− do
630− setUsedITBig
631− pure $ JsForeign "%0.shiftRight(%1)" [l,r]
632−cgOp (LASHR ITNative) [l, r] = pure $ JsForeign "%0 >> %1 |0" [l,r]
633−cgOp (LASHR (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 >> %1" [l,r]
634−cgOp (LASHR (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 >> %1" [l,r]
635−cgOp (LASHR (ITFixed IT32)) [l, r] = pure $ JsForeign "%0 >> %1|0" [l,r]
636−cgOp (LASHR (ITFixed IT64)) [l, r] =
637− do
638− setUsedITBig
639− pure $ JsForeign "%0.shiftRight(%1)" [l,r]
640−cgOp (LEq ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "==" l r
641−cgOp (LEq (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp "==" l r
642−cgOp (LEq (ATInt ITChar)) [l,r] = pure $ jsB2I $ JsBinOp "==" l r
643−cgOp (LEq (ATInt ITBig)) [l, r] =
644− do
645− setUsedITBig
646− pure $ jsB2I $ JsMethod l "equals" [r]
647−cgOp (LEq (ATInt (ITFixed IT8))) [l, r] = pure $ jsB2I $ JsBinOp "==" l r
648−cgOp (LEq (ATInt (ITFixed IT16))) [l, r] = pure $ jsB2I $ JsBinOp "==" l r
649−cgOp (LEq (ATInt (ITFixed IT32))) [l, r] = pure $ jsB2I $ JsBinOp "==" l r
650−cgOp (LEq (ATInt (ITFixed IT64))) [l, r] =
651− do
652− setUsedITBig
653− pure $ jsB2I $ JsMethod l "equals" [r]
654−cgOp (LLt (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 < %1" [l,r]
655−cgOp (LLt (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 < %1" [l,r]
656−cgOp (LLt (ITFixed IT32)) [l, r] = pure $ JsForeign "(%0>>>0) < (%1>>>0)" [l,r]
657−cgOp (LLt (ITFixed IT64)) [l, r] =
658− do
659− setUsedITBig
660− pure $ jsB2I $ JsForeign "%0.compareTo(%1) < 0" [l,r]
661−cgOp (LLe (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 <= %1" [l,r]
662−cgOp (LLe (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 <= %1" [l,r]
663−cgOp (LLe (ITFixed IT32)) [l, r] = pure $ JsForeign "(%0>>>0) <= (%1>>>0)" [l,r]
664−cgOp (LLe (ITFixed IT64)) [l, r] =
665− do
666− setUsedITBig
667− pure $ jsB2I $ JsForeign "%0.compareTo(%1) <= 0" [l,r]
668−cgOp (LGt (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 > %1" [l,r]
669−cgOp (LGt (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 > %1" [l,r]
670−cgOp (LGt (ITFixed IT32)) [l, r] = pure $ JsForeign "(%0>>>0) > (%1>>>0)" [l,r]
671−cgOp (LGt (ITFixed IT64)) [l, r] =
672− do
673− setUsedITBig
674− pure $ jsB2I $ JsForeign "%0.compareTo(%1) > 0" [l,r]
675−cgOp (LGe (ITFixed IT8)) [l, r] = pure $ JsForeign "%0 >= %1" [l,r]
676−cgOp (LGe (ITFixed IT16)) [l, r] = pure $ JsForeign "%0 >= %1" [l,r]
677−cgOp (LGe (ITFixed IT32)) [l, r] = pure $ JsForeign "(%0>>>0) >= (%1>>>0)" [l,r]
678−cgOp (LGe (ITFixed IT64)) [l, r] =
679− do
680− setUsedITBig
681− pure $ jsB2I $ JsForeign "%0.compareTo(%1) >= 0" [l,r]
682−cgOp (LSLt ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "<" l r
683−cgOp (LSLt (ATInt ITChar)) [l, r] = pure $ jsB2I $ JsBinOp "<" l r
684−cgOp (LSLt (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp "<" l r
685−cgOp (LSLt (ATInt ITBig)) [l, r] =
686− do
687− setUsedITBig
688− pure $ jsB2I $ JsForeign "%0.compareTo(%1) < 0" [l,r]
689−cgOp (LSLt (ATInt (ITFixed IT8))) [l, r] = pure $ jsB2I $ JsBinOp "<" l r
690−cgOp (LSLt (ATInt (ITFixed IT16))) [l, r] = pure $ jsB2I $ JsBinOp "<" l r
691−cgOp (LSLt (ATInt (ITFixed IT32))) [l, r] = pure $ jsB2I $ JsBinOp "<" l r
692−cgOp (LSLt (ATInt (ITFixed IT64))) [l, r] =
693− do
694− setUsedITBig
695− pure $ jsB2I $ JsForeign "%0.compareTo(%1) < 0" [l,r]
696−cgOp (LSLe ATFloat) [l, r] = pure $ jsB2I $ JsBinOp "<=" l r
697−cgOp (LSLe (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp "<=" l r
698−cgOp (LSLe (ATInt ITBig)) [l, r] =
699− do
700− setUsedITBig
701− pure $ jsB2I $ JsForeign "%0.compareTo(%1) <= 0" [l,r]
702−cgOp (LSLe (ATInt (ITFixed IT8))) [l, r] = pure $ jsB2I $ JsBinOp "<=" l r
703−cgOp (LSLe (ATInt (ITFixed IT16))) [l, r] = pure $ jsB2I $ JsBinOp "<=" l r
704−cgOp (LSLe (ATInt (ITFixed IT32))) [l, r] = pure $ jsB2I $ JsBinOp "<=" l r
705−cgOp (LSLe (ATInt (ITFixed IT64))) [l, r] =
706− do
707− setUsedITBig
708− pure $ jsB2I $ JsForeign "%0.compareTo(%1) <= 0" [l,r]
709−cgOp (LSGt ATFloat) [l, r] = pure $ jsB2I $ JsBinOp ">" l r
710−cgOp (LSGt (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp ">" l r
711−cgOp (LSGt (ATInt ITBig)) [l, r] =
712− do
713− setUsedITBig
714− pure $ jsB2I $ JsForeign "%0.compareTo(%1) > 0" [l,r]
715−cgOp (LSGt (ATInt (ITFixed IT8))) [l, r] = pure $ jsB2I $ JsBinOp ">" l r
716−cgOp (LSGt (ATInt (ITFixed IT16))) [l, r] = pure $ jsB2I $ JsBinOp ">" l r
717−cgOp (LSGt (ATInt (ITFixed IT32))) [l, r] = pure $ jsB2I $ JsBinOp ">" l r
718−cgOp (LSGt (ATInt (ITFixed IT64))) [l, r] =
719− do
720− setUsedITBig
721− pure $ jsB2I $ JsForeign "%0.compareTo(%1) > 0" [l,r]
722−cgOp (LSGe ATFloat) [l, r] = pure $ jsB2I $ JsBinOp ">=" l r
723−cgOp (LSGe (ATInt ITNative)) [l, r] = pure $ jsB2I $ JsBinOp ">=" l r
724−cgOp (LSGe (ATInt ITBig)) [l, r] =
725− do
726− setUsedITBig
727− pure $ jsB2I $ JsForeign "%0.compareTo(%1) >= 0" [l,r]
728−cgOp (LSGe (ATInt (ITFixed IT8))) [l, r] = pure $ jsB2I $ JsBinOp ">=" l r
729−cgOp (LSGe (ATInt (ITFixed IT16))) [l, r] = pure $ jsB2I $ JsBinOp ">=" l r
730−cgOp (LSGe (ATInt (ITFixed IT32))) [l, r] = pure $ jsB2I $ JsBinOp ">=" l r
731−cgOp (LSGe (ATInt (ITFixed IT64))) [l, r] =
732− do
733− setUsedITBig
734− pure $ jsB2I $ JsForeign "%0.compareTo(%1) >= 0" [l,r]
735−cgOp (LSExt ITNative ITBig) [x] =
736− do
737− setUsedITBig
738− pure $ JsForeign "new jsbn.BigInteger(String(%0))" [x]
739−cgOp (LZExt (ITFixed IT8) ITNative) [x] = pure x
740−cgOp (LZExt (ITFixed IT16) ITNative) [x] = pure x
741−cgOp (LZExt (ITFixed IT32) ITNative) [x] = pure x
742−cgOp (LZExt ITNative ITBig) [x] =
743− do
744− setUsedITBig
745− pure $ JsForeign "new jsbn.BigInteger(String(%0))" [x]
746−cgOp (LTrunc ITBig ITNative) [x] =
747− do
748− setUsedITBig
749− pure $ JsForeign "%0.intValue()|0" [x]
750−cgOp (LTrunc (ITFixed IT16) (ITFixed IT8)) [x] = pure $ JsForeign "%0 & 0xFF" [x]
751−cgOp (LTrunc (ITFixed IT32) (ITFixed IT8)) [x] = pure $ JsForeign "%0 & 0xFF" [x]
752−cgOp (LTrunc (ITFixed IT64) (ITFixed IT8)) [x] =
753− do
754− setUsedITBig
755− pure $ JsForeign "%0.intValue() & 0xFF" [x]
756−cgOp (LTrunc (ITFixed IT32) (ITFixed IT16)) [x] = pure $ JsForeign "%0 & 0xFFFF" [x]
757−cgOp (LTrunc (ITFixed IT64) (ITFixed IT16)) [x] =
758− do
759− setUsedITBig
760− pure $ JsForeign "%0.intValue() & 0xFFFF" [x]
761−cgOp (LTrunc (ITFixed IT64) (ITFixed IT32)) [x] =
762− do
763− setUsedITBig
764− pure $ JsForeign "%0.intValue() & 0xFFFFFFFF" [x]
765−cgOp (LTrunc ITBig (ITFixed IT64)) [x] =
766− do
767− setUsedITBig
768− pure $ JsForeign "%0.and(new jsbn.BigInteger(%1))" [x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
769−cgOp LStrConcat [l,r] = pure $ JsBinOp "+" l r
770−cgOp LStrLt [l, r] = pure $ jsB2I $ JsBinOp "<" l r
771−cgOp LStrEq [l,r] = pure $ jsB2I $ JsBinOp "==" l r
772−cgOp LStrLen [x] = pure $ JsForeign "%0.length" [x]
773−cgOp (LIntFloat ITNative) [x] = pure $ x
774−cgOp (LIntFloat ITBig) [x] =
775− do
776− setUsedITBig
777− pure $ JsForeign "%0.intValue()" [x]
778−cgOp (LFloatInt ITNative) [x] = pure $ JsForeign "%0|0" [x]
779−cgOp (LIntStr ITNative) [x] = pure $ JsApp "String" [x]
780−cgOp (LIntStr ITBig) [x] =
781− do
782− setUsedITBig
783− pure $ JsForeign "%0.toString()" [x]
784−cgOp (LStrInt ITNative) [x] = pure $ JsForeign "parseInt(%0)|0" [x]
785−cgOp (LStrInt ITBig) [x] =
786− do
787− setUsedITBig
788− pure $ JsForeign "new jsbn.BigInteger(%0)" [x]
789−cgOp (LFloatStr) [x] = pure $ JsApp "String" [x]
790−cgOp (LStrFloat) [x] = pure $ JsApp "parseFloat" [x]
791−cgOp (LChInt ITNative) [x] = pure $ JsForeign "%0.charCodeAt(0)|0" [x]
792−cgOp (LIntCh ITNative) [x] = pure $ JsApp "String.fromCharCode" [x]
793−cgOp LFExp [x] = pure $ JsApp "Math.exp" [x]
794−cgOp LFLog [x] = pure $ JsApp "Math.log" [x]
795−cgOp LFSin [x] = pure $ JsApp "Math.sin" [x]
796−cgOp LFCos [x] = pure $ JsApp "Math.cos" [x]
797−cgOp LFTan [x] = pure $ JsApp "Math.tan" [x]
798−cgOp LFASin [x] = pure $ JsApp "Math.asin" [x]
799−cgOp LFACos [x] = pure $ JsApp "Math.acos" [x]
800−cgOp LFATan [x] = pure $ JsApp "Math.atan" [x]
801−cgOp LFSqrt [x] = pure $ JsApp "Math.sqrt" [x]
802−cgOp LFFloor [x] = pure $ JsApp "Math.floor" [x]
803−cgOp LFCeil [x] = pure $ JsApp "Math.ceil" [x]
804−cgOp LFNegate [x] = pure $ JsForeign "-%0" [x]
805−cgOp LStrHead [x] = pure $ JsArrayProj (JsInt 0) x
806−cgOp LStrTail [x] = pure $ JsMethod x "slice" [JsInt 1]
807−cgOp LStrCons [l,r] = pure $ JsForeign "%0+%1" [l,r]
808−cgOp LStrIndex [x, y] = pure $ JsArrayProj y x
809−cgOp LStrRev [x] = pure $ JsForeign "%0.split('').reverse().join('')" [x]
810−cgOp LStrSubstr [offset,len,str] = pure $ JsForeign "%0.substr(Math.max(0,%1), Math.max(0, %2))" [str, offset, len]
553+cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
811554cgOp LReadStr [_] =
812555 do
813556 s <- get
@@ -818,9 +561,10 @@ cgOp LWriteStr [_,str] =
818561 s <- get
819562 put $ s {usedWrite = True}
820563 pure $ JsForeign (writeStrTemplate $ conf s) [str]
821−cgOp LSystemInfo [x] = pure $ JsApp "js_idris_systemInfo" [x]
822564cgOp (LExternal name) _ | name == sUN "prim__null" = pure JsNull
823565cgOp (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
824−cgOp LCrash [l] = pure $ JsErrorExp l
825−cgOp LNoOp [x] = pure x
826−cgOp op exps = error ("Operator " ++ show (op, exps) ++ " not implemented")
566+cgOp op exps = case Map.lookup op primDB of
567+ Just (useBigInt, pti, combinator) -> do
568+ when useBigInt setUsedITBig
569+ pure $ jsPrimCoerce pti PTAny $ combinator exps
570+ Nothing -> error ("Operator " ++ show (op, exps) ++ " not implemented")
src/IRTS/JavaScript/JsAST.hsdeleted−266
@@ -1,266 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
2−
3−module IRTS.JavaScript.JsAST
4− ( JsExpr(..)
5− , JsStmt(..)
6− , jsAst2Text
7− , jsStmt2Text
8− , jsLazy
9− , jsCurryLam
10− , jsCurryApp
11− , jsAppN
12− , js_aux_defs
13− , jsExpr2Stmt
14− , jsStmt2Expr
15− ) where
16−
17−import Data.Data
18−import Data.Text (Text)
19−import qualified Data.Text as T
20−
21−data JsStmt
22− = JsEmpty
23− | JsExprStmt JsExpr
24− | JsFun Text
25− [Text]
26− JsStmt
27− | JsSeq JsStmt
28− JsStmt
29− | JsReturn JsExpr
30− | JsDecVar Text
31− JsExpr
32− | JsDecConst Text
33− JsExpr
34− | JsDecLet Text
35− JsExpr
36− | JsSet JsExpr
37− JsExpr
38− | JsIf JsExpr
39− JsStmt
40− (Maybe JsStmt)
41− | JsSwitchCase JsExpr
42− [(JsExpr, JsStmt)]
43− (Maybe JsStmt)
44− | JsError JsExpr
45− | JsForever JsStmt
46− | JsContinue
47− | JsBreak
48− deriving (Show, Eq, Data, Typeable)
49−
50−data JsExpr
51− = JsNull
52− | JsUndefined
53− | JsThis
54− | JsLambda [Text]
55− JsStmt
56− | JsApp JsExpr
57− [JsExpr]
58− | JsPart JsExpr
59− Text
60− | JsMethod JsExpr
61− Text
62− [JsExpr]
63− | JsVar Text
64− | JsArrayProj JsExpr
65− JsExpr
66− | JsObj [(Text, JsExpr)]
67− | JsProp JsExpr
68− Text
69− | JsInt Int
70− | JsBool Bool
71− | JsInteger Integer
72− | JsDouble Double
73− | JsStr Text
74− | JsArray [JsExpr]
75− | JsErrorExp JsExpr
76− | JsUniOp Text
77− JsExpr
78− | JsBinOp Text
79− JsExpr
80− JsExpr
81− | JsForeign Text
82− [JsExpr]
83− | JsB2I JsExpr
84− | JsComment Text
85− | JsForce JsExpr
86− deriving (Show, Eq, Data, Typeable)
87−
88−indent :: Text -> Text
89−indent x =
90− let l = T.lines x
91− il = map (\y -> T.replicate 4 " " `T.append` y) l
92− in T.unlines il
93−
94−jsCurryLam :: [Text] -> JsExpr -> JsExpr
95−jsCurryLam [] body = body
96−jsCurryLam (x:xs) body = JsLambda [x] $ JsReturn $ jsCurryLam xs body
97−
98−jsCurryApp :: JsExpr -> [JsExpr] -> JsExpr
99−jsCurryApp fn [] = fn
100−jsCurryApp fn args = foldl (\ff aa -> JsApp ff [aa]) fn args
101−
102−jsAppN :: Text -> [JsExpr] -> JsExpr
103−jsAppN fn args = JsApp (JsVar fn) args
104−
105−jsStmt2Text :: JsStmt -> Text
106−jsStmt2Text JsEmpty = ""
107−jsStmt2Text (JsExprStmt e) = T.concat [jsAst2Text e, ";"]
108−jsStmt2Text (JsReturn x) = T.concat ["return ", jsAst2Text x, ";"]
109−jsStmt2Text (JsDecVar name exp) =
110− T.concat ["var ", name, " = ", jsAst2Text exp, ";"]
111−jsStmt2Text (JsDecConst name exp) =
112− T.concat ["const ", name, " = ", jsAst2Text exp, ";"]
113−jsStmt2Text (JsDecLet name exp) =
114− T.concat ["let ", name, " = ", jsAst2Text exp, ";"]
115−jsStmt2Text (JsFun name args body) =
116− T.concat
117− [ "function "
118− , name
119− , "("
120− , T.intercalate ", " args
121− , "){\n"
122− , indent $ jsStmt2Text body
123− , "}\n"
124− ]
125−jsStmt2Text (JsIf cond conseq (Just next@(JsIf _ _ _))) =
126− T.concat
127− [ "if("
128− , jsAst2Text cond
129− , ") {\n"
130− , indent $ jsStmt2Text conseq
131− , "} else "
132− , jsStmt2Text next
133− ]
134−jsStmt2Text (JsIf cond conseq (Just alt)) =
135− T.concat
136− [ "if("
137− , jsAst2Text cond
138− , ") {\n"
139− , indent $ jsStmt2Text conseq
140− , "} else {\n"
141− , indent $ jsStmt2Text alt
142− , "}\n"
143− ]
144−jsStmt2Text (JsIf cond conseq Nothing) =
145− T.concat ["if(", jsAst2Text cond, ") {\n", indent $ jsStmt2Text conseq, "}\n"]
146−jsStmt2Text (JsSwitchCase exp l d) =
147− T.concat
148− [ "switch("
149− , jsAst2Text exp
150− , "){\n"
151− , indent $ T.concat $ map case2Text l
152− , indent $ default2Text d
153− , "}\n"
154− ]
155− where
156− case2Text :: (JsExpr, JsStmt) -> Text
157− case2Text (x, y) =
158− T.concat
159− [ "case "
160− , jsAst2Text x
161− , ":\n"
162− , indent $ T.concat [jsStmt2Text y, ";\nbreak;\n"]
163− ]
164− default2Text :: Maybe JsStmt -> Text
165− default2Text Nothing = ""
166− default2Text (Just z) =
167− T.concat ["default:\n", indent $ T.concat [jsStmt2Text z, ";\nbreak;\n"]]
168−jsStmt2Text (JsError t) = T.concat ["throw new Error( ", jsAst2Text t, ");"]
169−jsStmt2Text (JsForever x) =
170− T.concat ["for(;;) {\n", indent $ jsStmt2Text x, "}\n"]
171−jsStmt2Text JsContinue = "continue;"
172−jsStmt2Text JsBreak = "break;"
173−jsStmt2Text (JsSeq JsEmpty y) = jsStmt2Text y
174−jsStmt2Text (JsSeq x JsEmpty) = jsStmt2Text x
175−jsStmt2Text (JsSeq x y) = T.concat [jsStmt2Text x, "\n", jsStmt2Text y]
176−jsStmt2Text (JsSet term exp) =
177− T.concat [jsAst2Text term, " = ", jsAst2Text exp, ";"]
178−
179−jsAst2Text :: JsExpr -> Text
180−jsAst2Text JsNull = "null"
181−jsAst2Text JsUndefined = "(void 0)"
182−jsAst2Text JsThis = "this"
183−jsAst2Text (JsLambda args body) =
184− T.concat
185− [ "(function"
186− , "("
187− , T.intercalate ", " args
188− , "){\n"
189− , indent $ jsStmt2Text body
190− , "})"
191− ]
192−jsAst2Text (JsApp fn args) =
193− T.concat [jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]
194−jsAst2Text (JsMethod obj name args) =
195− T.concat
196− [ jsAst2Text obj
197− , "."
198− , name
199− , "("
200− , T.intercalate ", " $ map jsAst2Text args
201− , ")"
202− ]
203−jsAst2Text (JsPart obj name) =
204− T.concat [jsAst2Text obj, "[", T.pack (show name), "]"]
205−jsAst2Text (JsVar x) = x
206−jsAst2Text (JsObj props) =
207− T.concat
208− [ "({"
209− , T.intercalate
210− ", "
211− (map (\(name, val) -> T.concat [name, ": ", jsAst2Text val]) props)
212− , "})"
213− ]
214−jsAst2Text (JsProp object name) = T.concat [jsAst2Text object, ".", name]
215−jsAst2Text (JsArrayProj i exp) =
216− T.concat [jsAst2Text exp, "[", jsAst2Text i, "]"]
217−jsAst2Text (JsInt i) = T.pack $ show i
218−jsAst2Text (JsBool True) = T.pack "true"
219−jsAst2Text (JsBool False) = T.pack "false"
220−jsAst2Text (JsDouble d) = T.pack $ show d
221−jsAst2Text (JsInteger i) = T.pack $ show i
222−jsAst2Text (JsStr s) = T.pack $ show s
223−jsAst2Text (JsArray l) =
224− T.concat ["[", T.intercalate ", " (map jsAst2Text l), "]"]
225−jsAst2Text (JsErrorExp t) =
226− T.concat ["js_idris_throw2(new Error( ", jsAst2Text t, "))"]
227−jsAst2Text (JsBinOp op a1 a2) =
228− T.concat ["(", jsAst2Text a1, " ", op, " ", jsAst2Text a2, ")"]
229−jsAst2Text (JsUniOp op a) = T.concat ["(", op, jsAst2Text a, ")"]
230−jsAst2Text (JsForeign code args) =
231− let args_repl c i [] = c
232− args_repl c i (t:r) =
233− args_repl (T.replace ("%" `T.append` T.pack (show i)) t c) (i + 1) r
234− in T.concat ["(", args_repl code 0 (map jsAst2Text args), ")"]
235−jsAst2Text (JsB2I x) = jsAst2Text $ JsBinOp "+" x (JsInt 0)
236−jsAst2Text (JsComment c) = T.concat ["/*", c, "*/"]
237−jsAst2Text (JsForce e) = T.concat ["js_idris_force(", jsAst2Text e, ")"]
238−
239−jsLazy :: JsExpr -> JsExpr
240−jsLazy e = JsObj [("js_idris_lazy_calc", (JsLambda [] $ JsReturn e))]
241−
242−throw2 =
243− T.concat ["var js_idris_throw2 = function (x){\n", " throw x;\n", "}\n"]
244−
245−force =
246− T.concat
247− [ "var js_idris_force = function (x){\n"
248− , " if(x.js_idris_lazy_calc === undefined){\n"
249− , " return x\n"
250− , " }else{\n"
251− , " if(x.js_idris_lazy_val === undefined){\n"
252− , " x.js_idris_lazy_val = x.js_idris_lazy_calc()\n"
253− , " }\n"
254− , " return x.js_idris_lazy_val\n"
255− , " }\n"
256− , "}\n"
257− ]
258−
259−js_aux_defs = T.concat [throw2, force]
260−
261−jsExpr2Stmt :: JsExpr -> JsStmt
262−jsExpr2Stmt = JsExprStmt
263−
264−jsStmt2Expr :: JsStmt -> JsExpr
265−jsStmt2Expr (JsExprStmt x) = x
266−jsStmt2Expr x = JsApp (JsLambda [] x) []
src/IRTS/JavaScript/Name.hsnew file+78
@@ -0,0 +1,78 @@
1+{-# LANGUAGE OverloadedStrings, PatternGuards #-}
2+
3+module IRTS.JavaScript.Name
4+ ( jsName
5+ , jsNameGenerated
6+ , Partial(..)
7+ , jsNamePartial
8+ , jsTailCallOptimName
9+ ) where
10+
11+import Data.Char
12+import Data.List
13+import qualified Data.Map.Strict as Map
14+import Data.Text (Text)
15+import qualified Data.Text as T
16+import Idris.Core.TT
17+import IRTS.JavaScript.AST
18+
19+jsEscape :: String -> String
20+jsEscape = concatMap jschar
21+ where
22+ jschar x
23+ | isAlpha x || isDigit x = [x]
24+ | x == '.' = "__"
25+ | otherwise = "_" ++ show (fromEnum x) ++ "_"
26+
27+showCGJS :: Name -> String
28+showCGJS (UN n) = "u$" ++ jsEscape (T.unpack n)
29+showCGJS (NS n s) = "q_" ++ show (length s) ++ "$" ++ showSep "$" (map (jsEscape . T.unpack) (reverse s))
30+ ++ "$" ++ showCGJS n
31+showCGJS (MN _ u) | u == txt "underscore" = "_"
32+showCGJS (MN i s) = "t$" ++ jsEscape (T.unpack s) ++ "$" ++ show i
33+showCGJS (SN s) = showCGJS' s
34+ where
35+ showCGJS' (WhereN i p c) =
36+ "where$" ++ showCGJS p ++ "$" ++ showCGJS c ++ "$" ++ show i
37+ showCGJS' (WithN i n) = "with$" ++ showCGJS n ++ "$" ++ show i
38+ showCGJS' (ImplementationN cl impl) =
39+ "impl_" ++ show (length impl) ++ "$" ++ showCGJS cl ++ "$"
40+ ++ showSep "$" (map (jsEscape . T.unpack) impl)
41+ showCGJS' (MethodN m) = "meth$" ++ showCGJS m
42+ showCGJS' (ParentN p c) = "parent$" ++ showCGJS p ++ "$" ++ show c
43+ showCGJS' (CaseN fc c) = "case$" ++ showCGJS c ++ "$" ++ showFC' fc
44+ showCGJS' (ElimN sn) = "elim$" ++ showCGJS sn
45+ showCGJS' (ImplementationCtorN n) = "ictor$" ++ showCGJS n
46+ showCGJS' (MetaN parent meta) =
47+ "meta$" ++ showCGJS parent ++ "$" ++ showCGJS meta
48+ showFC' (FC' NoFC) = ""
49+ showFC' (FC' (FileFC f)) = "_" ++ cgFN f
50+ showFC' (FC' (FC f s e))
51+ | s == e = "_" ++ cgFN f ++ "_" ++ show (fst s) ++ "_" ++ show (snd s)
52+ | otherwise =
53+ "_" ++
54+ cgFN f ++
55+ "_" ++
56+ show (fst s) ++
57+ "_" ++ show (snd s) ++ "_" ++ show (fst e) ++ "_" ++ show (snd e)
58+ cgFN =
59+ concatMap
60+ (\c ->
61+ if not (isDigit c || isLetter c)
62+ then "__"
63+ else [c])
64+showCGJS (SymRef i) = error "can't do codegen for a symbol reference"
65+
66+jsName :: Name -> Text
67+jsName n = T.pack $ showCGJS n
68+
69+jsNameGenerated :: Int -> Text
70+jsNameGenerated v = T.pack $ "$cg$" ++ show v
71+
72+data Partial = Partial Name Int Int deriving (Eq, Ord)
73+
74+jsNamePartial :: Partial -> Text
75+jsNamePartial (Partial n i j) = T.concat ["$partial_", T.pack $ show i, "_", T.pack $ show j, "$" , jsName n]
76+
77+jsTailCallOptimName :: Text -> Text
78+jsTailCallOptimName x = T.concat ["$tco$", x]
src/IRTS/JavaScript/PrimOp.hsnew file+229
@@ -0,0 +1,229 @@
1+{-# LANGUAGE OverloadedStrings, PatternGuards, StandaloneDeriving #-}
2+
3+module IRTS.JavaScript.PrimOp
4+ ( PrimF
5+ , PrimDec
6+ , JsPrimTy(..)
7+ , primDB
8+ , jsPrimCoerce
9+ ) where
10+
11+import Data.Char
12+import Data.List
13+import qualified Data.Map.Strict as Map
14+import Data.Text (Text)
15+import qualified Data.Text as T
16+import Idris.Core.TT
17+import IRTS.JavaScript.AST
18+import IRTS.Lang
19+
20+data JsPrimTy = PTBool | PTAny deriving (Eq, Ord)
21+
22+type PrimF = [JsExpr] -> JsExpr
23+type PrimDec = (Bool, JsPrimTy, PrimF)
24+
25+deriving instance Ord PrimFn
26+
27+primDB :: Map.Map PrimFn PrimDec
28+primDB =
29+ Map.fromList [
30+ item (LPlus ATFloat) False PTAny $ binop "+"
31+ , item (LPlus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) + %1.charCodeAt(0))"
32+ , item (LPlus (ATInt ITNative)) False PTAny $ JsForeign "%0+%1|0"
33+ , item (LPlus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 + %1 & 0xFF"
34+ , item (LPlus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 + %1 & 0xFFFF"
35+ , item (LPlus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0+%1|0"
36+ , item (LPlus (ATInt ITBig)) True PTAny $ method "add"
37+ , item (LPlus (ATInt (ITFixed IT64))) True PTAny $
38+ \[l, r] -> JsForeign "%0.add(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
39+ , item (LMinus ATFloat) False PTAny $ binop "-"
40+ , item (LMinus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) - %1.charCodeAt(0))"
41+ , item (LMinus (ATInt ITNative)) False PTAny $ JsForeign "%0-%1|0"
42+ , item (LMinus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 - %1 & 0xFF"
43+ , item (LMinus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 - %1 & 0xFFFF"
44+ , item (LMinus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0-%1|0"
45+ , item (LMinus (ATInt ITBig)) True PTAny $ method "subtract"
46+ , item (LMinus (ATInt (ITFixed IT64))) True PTAny $
47+ \[l, r] -> JsForeign "%0.subtract(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
48+ , item (LTimes ATFloat) False PTAny $ binop "*"
49+ , item (LTimes (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) * %1.charCodeAt(0))"
50+ , item (LTimes (ATInt ITNative)) False PTAny $ JsForeign "%0*%1|0"
51+ , item (LTimes (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 * %1 & 0xFF"
52+ , item (LTimes (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 * %1 & 0xFFFF"
53+ , item (LTimes (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0*%1|0"
54+ , item (LTimes (ATInt ITBig)) True PTAny $ method "multiply"
55+ , item (LTimes (ATInt (ITFixed IT64))) True PTAny $
56+ \[l, r] -> JsForeign "%0.multiply(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
57+ , item (LUDiv (ITFixed IT8)) False PTAny $ JsForeign "%0 / %1"
58+ , item (LUDiv (ITFixed IT16)) False PTAny $ JsForeign "%0 / %1"
59+ , item (LUDiv (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0) / (%1>>>0) |0"
60+ , item (LUDiv (ITFixed IT64)) True PTAny $ JsForeign "%0.divide(%1)"
61+ , item (LSDiv ATFloat) False PTAny $ binop "/"
62+ , item (LSDiv (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 / %1"
63+ , item (LSDiv (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 / %1"
64+ , item (LSDiv (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0 / %1 |0"
65+ , item (LSDiv (ATInt (ITFixed IT64))) True PTAny $ JsForeign "%0.divide(%1)"
66+ , item (LSDiv (ATInt ITNative)) False PTAny $ JsForeign "%0/%1|0"
67+ , item (LSDiv (ATInt ITBig)) True PTAny $ method "divide"
68+ , item (LURem (ITFixed IT8)) False PTAny $ JsForeign "%0 % %1"
69+ , item (LURem (ITFixed IT16)) False PTAny $ JsForeign "%0 % %1"
70+ , item (LURem (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0) % (%1>>>0) |0"
71+ , item (LURem (ITFixed IT64)) True PTAny $ method "remainder"
72+ , item (LSRem ATFloat) False PTAny $ binop "%"
73+ , item (LSRem (ATInt ITNative)) False PTAny $ JsForeign "%0 % %1 |0"
74+ , item (LSRem (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 % %1"
75+ , item (LSRem (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 % %1"
76+ , item (LSRem (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0 % %1 |0"
77+ , item (LSRem (ATInt (ITFixed IT64))) True PTAny $ method "remainder"
78+ , item (LSRem (ATInt ITBig)) True PTAny $ method "remainder"
79+ , item (LAnd ITNative) False PTAny $ JsForeign "%0 & %1"
80+ , item (LAnd (ITFixed IT8)) False PTAny $ JsForeign "%0 & %1"
81+ , item (LAnd (ITFixed IT16)) False PTAny $ JsForeign "%0 & %1"
82+ , item (LAnd (ITFixed IT32)) False PTAny $ JsForeign "%0 & %1"
83+ , item (LAnd (ITFixed IT64)) True PTAny $ method "and"
84+ , item (LAnd ITBig) True PTAny $ method "and"
85+ , item (LOr ITNative) False PTAny $ JsForeign "%0 | %1"
86+ , item (LOr (ITFixed IT8)) False PTAny $ JsForeign "%0 | %1"
87+ , item (LOr (ITFixed IT16)) False PTAny $ JsForeign "%0 | %1"
88+ , item (LOr (ITFixed IT32)) False PTAny $ JsForeign "%0 | %1"
89+ , item (LOr (ITFixed IT64)) True PTAny $ method "or"
90+ , item (LOr ITBig) True PTAny $ method "or"
91+ , item (LXOr ITNative) False PTAny $ JsForeign "%0 ^ %1"
92+ , item (LXOr (ITFixed IT8)) False PTAny $ JsForeign "%0 ^ %1"
93+ , item (LXOr (ITFixed IT16)) False PTAny $ JsForeign "%0 ^ %1"
94+ , item (LXOr (ITFixed IT32)) False PTAny $ JsForeign "%0 ^ %1"
95+ , item (LXOr (ITFixed IT64)) True PTAny $ method "xor"
96+ , item (LXOr ITBig) True PTAny $ method "xor"
97+ , item (LSHL ITNative) False PTAny $ JsForeign "%0 << %1 |0"
98+ , item (LSHL (ITFixed IT8)) False PTAny $ JsForeign "%0 << %1 & 0xFF"
99+ , item (LSHL (ITFixed IT16)) False PTAny $ JsForeign "%0 << %1 & 0xFFFF"
100+ , item (LSHL (ITFixed IT32)) False PTAny $ JsForeign "%0 << %1 | 0"
101+ , item (LSHL (ITFixed IT64)) True PTAny $
102+ \[l, r] -> JsForeign "%0.shiftLeft(%1).and(new jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
103+ , item (LSHL ITBig) True PTAny $ method "shiftLeft"
104+ , item (LLSHR ITNative) False PTAny $ JsForeign "%0 >> %1 |0"
105+ , item (LLSHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >> %1"
106+ , item (LLSHR (ITFixed IT16)) False PTAny $ JsForeign "%0 >> %1"
107+ , item (LLSHR (ITFixed IT32)) False PTAny $ JsForeign "%0 >> %1|0"
108+ , item (LLSHR (ITFixed IT64)) True PTAny $ JsForeign "%0.shiftRight(%1)"
109+ , item (LASHR ITNative) False PTAny $ JsForeign "%0 >> %1 |0"
110+ , item (LASHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >> %1"
111+ , item (LASHR (ITFixed IT16)) False PTAny $ JsForeign "%0 >> %1"
112+ , item (LASHR (ITFixed IT32)) False PTAny $ JsForeign "%0 >> %1|0"
113+ , item (LASHR (ITFixed IT64)) True PTAny $ JsForeign "%0.shiftRight(%1)"
114+ , item (LEq ATFloat) False PTBool $ binop "==="
115+ , item (LEq (ATInt ITNative)) False PTBool $ binop "==="
116+ , item (LEq (ATInt ITChar)) False PTBool $ binop "==="
117+ , item (LEq (ATInt ITBig)) True PTBool $ method "equals"
118+ , item (LEq (ATInt (ITFixed IT8))) False PTBool $ binop "==="
119+ , item (LEq (ATInt (ITFixed IT16))) False PTBool $ binop "==="
120+ , item (LEq (ATInt (ITFixed IT32))) False PTBool $ binop "==="
121+ , item (LEq (ATInt (ITFixed IT64))) True PTBool $ method "equals"
122+ , item (LLt (ITFixed IT8)) False PTBool $ JsForeign "%0 < %1"
123+ , item (LLt (ITFixed IT16)) False PTBool $ JsForeign "%0 < %1"
124+ , item (LLt (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) < (%1>>>0)"
125+ , item (LLt (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
126+ , item (LLe (ITFixed IT8)) False PTBool $ JsForeign "%0 <= %1"
127+ , item (LLe (ITFixed IT16)) False PTBool $ JsForeign "%0 <= %1"
128+ , item (LLe (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) <= (%1>>>0)"
129+ , item (LLe (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
130+ , item (LGt (ITFixed IT8)) False PTBool $ JsForeign "%0 > %1"
131+ , item (LGt (ITFixed IT16)) False PTBool $ JsForeign "%0 > %1"
132+ , item (LGt (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) > (%1>>>0)"
133+ , item (LGt (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
134+ , item (LGe (ITFixed IT8)) False PTBool $ JsForeign "%0 >= %1"
135+ , item (LGe (ITFixed IT16)) False PTBool $ JsForeign "%0 >= %1"
136+ , item (LGe (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) >= (%1>>>0)"
137+ , item (LGe (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
138+ , item (LSLt ATFloat) False PTBool $ binop "<"
139+ , item (LSLt (ATInt ITChar)) False PTBool $ binop "<"
140+ , item (LSLt (ATInt ITNative)) False PTBool $ binop "<"
141+ , item (LSLt (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
142+ , item (LSLt (ATInt (ITFixed IT8))) False PTBool $ binop "<"
143+ , item (LSLt (ATInt (ITFixed IT16))) False PTBool $ binop "<"
144+ , item (LSLt (ATInt (ITFixed IT32))) False PTBool $ binop "<"
145+ , item (LSLt (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
146+ , item (LSLe ATFloat) False PTBool $ binop "<="
147+ , item (LSLe (ATInt ITNative)) False PTBool $ binop "<="
148+ , item (LSLe (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
149+ , item (LSLe (ATInt (ITFixed IT8))) False PTBool $ binop "<="
150+ , item (LSLe (ATInt (ITFixed IT16))) False PTBool $ binop "<="
151+ , item (LSLe (ATInt (ITFixed IT32))) False PTBool $ binop "<="
152+ , item (LSLe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
153+ , item (LSGt ATFloat) False PTBool $ binop ">"
154+ , item (LSGt (ATInt ITNative)) False PTBool $ binop ">"
155+ , item (LSGt (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
156+ , item (LSGt (ATInt (ITFixed IT8))) False PTBool $ binop ">"
157+ , item (LSGt (ATInt (ITFixed IT16))) False PTBool $ binop ">"
158+ , item (LSGt (ATInt (ITFixed IT32))) False PTBool $ binop ">"
159+ , item (LSGt (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
160+ , item (LSGe ATFloat) False PTBool $ binop ">="
161+ , item (LSGe (ATInt ITNative)) False PTBool $ binop ">="
162+ , item (LSGe (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
163+ , item (LSGe (ATInt (ITFixed IT8))) False PTBool $ binop ">="
164+ , item (LSGe (ATInt (ITFixed IT16))) False PTBool $ binop ">="
165+ , item (LSGe (ATInt (ITFixed IT32))) False PTBool $ binop ">="
166+ , item (LSGe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
167+ , item (LSExt ITNative ITBig) True PTAny $ JsForeign "new jsbn.BigInteger(''+%0)"
168+ , item (LZExt (ITFixed IT8) ITNative) False PTAny $ head
169+ , item (LZExt (ITFixed IT16) ITNative) False PTAny $ head
170+ , item (LZExt (ITFixed IT32) ITNative) False PTAny $ head
171+ , item (LZExt ITNative ITBig) True PTAny $ JsForeign "new jsbn.BigInteger(''+%0)"
172+ , item (LTrunc ITBig ITNative) True PTAny $ JsForeign "%0.intValue()|0"
173+ , item (LTrunc (ITFixed IT16) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"
174+ , item (LTrunc (ITFixed IT32) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"
175+ , item (LTrunc (ITFixed IT64) (ITFixed IT8)) True PTAny $ JsForeign "%0.intValue() & 0xFF"
176+ , item (LTrunc (ITFixed IT32) (ITFixed IT16)) False PTAny $ JsForeign "%0 & 0xFFFF"
177+ , item (LTrunc (ITFixed IT64) (ITFixed IT16)) True PTAny $ JsForeign "%0.intValue() & 0xFFFF"
178+ , item (LTrunc (ITFixed IT64) (ITFixed IT32)) True PTAny $ JsForeign "%0.intValue() & 0xFFFFFFFF"
179+ , item (LTrunc ITBig (ITFixed IT64)) True PTAny $
180+ \[x] -> JsForeign "%0.and(new jsbn.BigInteger(%1))" [x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
181+ , item LStrConcat False PTAny $ binop "+"
182+ , item LStrLt False PTBool $ binop "<"
183+ , item LStrEq False PTBool $ binop "=="
184+ , item LStrLen False PTAny $ JsForeign "%0.length"
185+ , item (LIntFloat ITNative) False PTAny $ head
186+ , item (LIntFloat ITBig) True PTAny $ JsForeign "%0.intValue()"
187+ , item (LFloatInt ITNative) False PTAny $ JsForeign "%0|0"
188+ , item (LIntStr ITNative) False PTAny $ JsForeign "''+%0"
189+ , item (LIntStr ITBig) True PTAny $ JsForeign "%0.toString()"
190+ , item (LStrInt ITNative) False PTAny $ JsForeign "parseInt(%0)|0"
191+ , item (LStrInt ITBig) True PTAny $ JsForeign "new jsbn.BigInteger(%0)"
192+ , item (LFloatStr) False PTAny $ JsForeign "''+%0"
193+ , item (LStrFloat) False PTAny $ jsAppN "parseFloat"
194+ , item (LChInt ITNative) False PTAny $ JsForeign "%0.charCodeAt(0)|0"
195+ , item (LIntCh ITNative) False PTAny $ jsAppN "String.fromCharCode"
196+ , item LFExp False PTAny $ jsAppN "Math.exp"
197+ , item LFLog False PTAny $ jsAppN "Math.log"
198+ , item LFSin False PTAny $ jsAppN "Math.sin"
199+ , item LFCos False PTAny $ jsAppN "Math.cos"
200+ , item LFTan False PTAny $ jsAppN "Math.tan"
201+ , item LFASin False PTAny $ jsAppN "Math.asin"
202+ , item LFACos False PTAny $ jsAppN "Math.acos"
203+ , item LFATan False PTAny $ jsAppN "Math.atan"
204+ , item LFSqrt False PTAny $ jsAppN "Math.sqrt"
205+ , item LFFloor False PTAny $ jsAppN "Math.floor"
206+ , item LFCeil False PTAny $ jsAppN "Math.ceil"
207+ , item LFNegate False PTAny $ JsForeign "-%0"
208+ , item LStrHead False PTAny $ \[x] -> JsArrayProj (JsInt 0) x
209+ , item LStrTail False PTAny $ \[x] -> JsMethod x "slice" [JsInt 1]
210+ , item LStrCons False PTAny $ JsForeign "%0+%1"
211+ , item LStrIndex False PTAny $ \[x, y] -> JsArrayProj y x
212+ , item LStrRev False PTAny $ JsForeign "%0.split('').reverse().join('')"
213+ , item LStrSubstr False PTAny $ JsForeign "%0.slice(Math.max(0,%1), Math.max(0, %2))"
214+ , item LSystemInfo False PTAny $ jsAppN "js_idris_systemInfo"
215+ , item LCrash False PTAny $ \[l] -> JsErrorExp l
216+ , item LNoOp False PTAny $ head
217+ ]
218+ where
219+ item :: PrimFn -> Bool -> JsPrimTy -> PrimF -> (PrimFn, PrimDec)
220+ item fn ubi pty c = (fn, (ubi, pty, c))
221+ binop op [l, r] = JsBinOp op l r
222+ method op (l:r) = JsMethod l op r
223+
224+jsB2I :: JsExpr -> JsExpr
225+jsB2I x = JsForeign "%0 ? 1|0 : 0|0" [x]
226+
227+jsPrimCoerce :: JsPrimTy -> JsPrimTy -> JsExpr -> JsExpr
228+jsPrimCoerce PTBool PTAny x = jsB2I x
229+jsPrimCoerce _ _ x = x
src/IRTS/JavaScript/Specialize.hsnew file+109
@@ -0,0 +1,109 @@
1+{-# LANGUAGE OverloadedStrings, PatternGuards #-}
2+
3+module IRTS.JavaScript.Specialize
4+ ( SCtor
5+ , STest
6+ , SProj
7+ , specialCased
8+ , specialCall
9+ , qualifyN
10+ ) where
11+
12+import Data.Char
13+import Data.List
14+import qualified Data.Map.Strict as Map
15+import Data.Text (Text)
16+import qualified Data.Text as T
17+import Idris.Core.TT
18+import IRTS.JavaScript.AST
19+
20+split :: Char -> String -> [String]
21+split c "" = [""]
22+split c (x:xs)
23+ | c == x = "" : split c xs
24+ | otherwise =
25+ let ~(h:t) = split c xs
26+ in ((x : h) : t)
27+
28+qualify :: String -> Name -> Name
29+qualify "" n = n
30+qualify ns n = sNS n (reverse $ split '.' ns)
31+
32+qualifyN :: String -> String -> Name
33+qualifyN ns n = qualify ns $ sUN n
34+
35+-- special-cased constructors
36+type SCtor = [JsExpr] -> JsExpr
37+
38+type STest = JsExpr -> JsExpr
39+
40+type SProj = JsExpr -> Int -> JsExpr
41+
42+constructorOptimizeDB :: Map.Map Name (SCtor, STest, SProj)
43+constructorOptimizeDB =
44+ Map.fromList
45+ [ item "Prelude.Bool" "True" (const $ JsBool True) trueTest cantProj
46+ , item "Prelude.Bool" "False" (const $ JsBool False) falseTest cantProj
47+ -- , item "Prelude.List" "::" cons fillList uncons
48+ -- , item "Prelude.List" "Nil" nil emptyList cantProj
49+ -- , item "Prelude.Maybe" "Just" (\[x] -> x) notNoneTest justProj
50+ -- , item "Prelude.Maybe" "Nothing" (const $ JsUndefined) noneTest cantProj
51+ ]
52+ -- constructors
53+ where
54+ nil = const $ JsArray []
55+ cons [h, t] = JsMethod (JsArray [h]) "concat" [t]
56+ -- tests
57+ --trueTest e = JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") e
58+ trueTest = id
59+ falseTest e = JsUniOp (T.pack "!") e
60+ emptyList e = JsBinOp "===" (JsProp e "length") (JsInt 0)
61+ fillList e = JsBinOp ">" (JsProp e "length") (JsInt 0)
62+ noneTest e = JsBinOp "===" e JsUndefined
63+ notNoneTest e = JsBinOp "!==" e JsUndefined
64+ -- projections
65+ justProj x n = x
66+ uncons x 1 = JsArrayProj (JsInt 0) x
67+ uncons x 2 = JsMethod x "slice" [JsInt 1]
68+ cantProj x j = error $ "This type should be projected"
69+ item :: String
70+ -> String
71+ -> SCtor
72+ -> STest
73+ -> SProj
74+ -> (Name, (SCtor, STest, SProj))
75+ item ns n ctor test match = (qualifyN ns n, (ctor, test, match))
76+
77+specialCased :: Name -> Maybe (SCtor, STest, SProj)
78+specialCased n = Map.lookup n constructorOptimizeDB
79+
80+-- special functions
81+type SSig = (Int, [JsExpr] -> JsExpr)
82+
83+callSpecializeDB :: Map.Map Name (SSig)
84+callSpecializeDB =
85+ Map.fromList
86+ [ qb "Eq" "Int" "==" "==="
87+ , qb "Ord" "Int" "<" "<"
88+ , qb "Ord" "Int" ">" ">"
89+ , qb "Ord" "Int" "<=" "<="
90+ , qb "Ord" "Int" ">=" ">="
91+ , qb "Eq" "Double" "==" "==="
92+ , qb "Ord" "Double" "<" "<"
93+ , qb "Ord" "Double" ">" ">"
94+ , qb "Ord" "Double" "<=" "<="
95+ , qb "Ord" "Double" ">=" ">="
96+ ]
97+ where
98+ qb intf ty op jsop =
99+ ( qualify "Prelude.Interfaces" $
100+ SN $
101+ WhereN
102+ 0
103+ (qualify "Prelude.Interfaces" $
104+ SN $ ImplementationN (qualifyN "Prelude.Interfaces" intf) [ty])
105+ (SN $ MethodN $ UN op)
106+ , (2, \[x, y] -> JsBinOp jsop x y))
107+
108+specialCall :: Name -> Maybe SSig
109+specialCall n = Map.lookup n callSpecializeDB