haste-compiler 0.4.3 → 0.4.4
raw patch · 28 files changed
+609/−303 lines, 28 filesdep ~networkdep ~network-uridep ~websockets
Dependency ranges changed: network, network-uri, websockets
Files
- haste-compiler.cabal +42/−13
- lib/Weak.js +15/−0
- lib/md5.js +111/−110
- lib/rts.js +22/−11
- lib/stdlib.js +35/−14
- libraries/haste-lib/src/Haste.hs +5/−0
- libraries/haste-lib/src/Haste/App.hs +5/−3
- libraries/haste-lib/src/Haste/App/Monad.hs +20/−10
- libraries/haste-lib/src/Haste/Binary.hs +2/−2
- libraries/haste-lib/src/Haste/Callback.hs +4/−0
- libraries/haste-lib/src/Haste/DOM.hs +66/−2
- libraries/haste-lib/src/Haste/Graphics/Canvas.hs +48/−14
- libraries/haste-lib/src/Haste/JSON.hs +5/−5
- libraries/haste-lib/src/Haste/JSType.hs +20/−9
- src/Data/JSTarget/AST.hs +1/−1
- src/Data/JSTarget/Binary.hs +2/−2
- src/Data/JSTarget/Constructors.hs +2/−2
- src/Data/JSTarget/Optimize.hs +14/−8
- src/Data/JSTarget/Print.hs +7/−1
- src/Data/JSTarget/Traversal.hs +6/−4
- src/Haste/CodeGen.hs +6/−4
- src/Haste/Config.hs +1/−1
- src/Haste/Environment.hs +48/−44
- src/Haste/GHCPaths.hs +35/−0
- src/Haste/PrimOps.hs +8/−2
- src/Haste/Version.hs +46/−32
- src/Main.hs +3/−2
- src/haste-boot.hs +30/−7
haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name: haste-compiler-Version: 0.4.3+Version: 0.4.4 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler@@ -35,6 +35,7 @@ debug.js Canvas.js Handle.js+ Weak.js Flag portable Description:@@ -42,15 +43,31 @@ still local to each user. Primarily useful for global installs. Default: False +Flag static+ Description:+ Build a statically linked binary. Only really useful together with+ portable.+ Default: False++Flag only-library+ Description:+ Only install the Haste server-side libraries; no binaries.+ This is useful if you installed pre-built binaries but still want+ to use Haste with vanilla GHC, for Haste.App for instance.+ Default: False+ source-repository head type: git location: https://github.com/valderman/haste-compiler.git Executable haste-boot+ if flag(only-library)+ buildable: False Main-Is: haste-boot.hs Other-Modules: Haste.Version Haste.Environment+ Haste.GHCPaths Hs-Source-Dirs: src if flag(portable) CPP-Options: -DPORTABLE@@ -71,10 +88,13 @@ Default-Language: Haskell98 Executable hastec+ if flag(only-library)+ buildable: False Hs-Source-Dirs: src GHC-Options: -Wall -O2 if flag(portable) CPP-Options: -DPORTABLE+ if flag(static) if os(windows) GHC-Options: -static -optl-static else@@ -106,6 +126,7 @@ Haste.Opts Haste.Version Haste.Environment+ Haste.GHCPaths Haste.Config Haste.Monad Haste.PrimOps@@ -126,10 +147,13 @@ default-language: Haskell98 Executable haste-inst+ if flag(only-library)+ buildable: False Main-Is: haste-inst.hs Hs-Source-Dirs: src if flag(portable) CPP-Options: -DPORTABLE+ if flag(static) if os(windows) GHC-Options: -static -optl-static else@@ -144,10 +168,13 @@ default-language: Haskell98 Executable haste-pkg+ if flag(only-library)+ buildable: False Main-Is: haste-pkg.hs Hs-Source-Dirs: src if flag(portable) CPP-Options: -DPORTABLE+ if flag(static) if os(windows) GHC-Options: -static -optl-static else@@ -163,6 +190,8 @@ default-language: Haskell98 Executable haste-install-his+ if flag(only-library)+ buildable: False Main-Is: haste-install-his.hs Hs-Source-Dirs: src if flag(portable)@@ -176,9 +205,12 @@ default-language: Haskell98 Executable haste-copy-pkg+ if flag(only-library)+ buildable: False Main-Is: haste-copy-pkg.hs Other-Modules: Haste.Environment+ Haste.GHCPaths Hs-Source-Dirs: src if flag(portable) CPP-Options: -DPORTABLE@@ -191,9 +223,12 @@ default-language: Haskell98 Executable haste-cat+ if flag(only-library)+ buildable: False Main-Is: haste-cat.hs Other-Modules: Haste.Environment+ Haste.GHCPaths Hs-Source-Dirs: src if flag(portable) CPP-Options: -DPORTABLE@@ -236,7 +271,9 @@ Haste.JSType Haste.Callback Haste.Compiler.Flags+ Haste.Version Haste.Environment+ Haste.GHCPaths Paths_haste_compiler Haste.Hash Haste.Random@@ -267,16 +304,8 @@ process, ghc-paths, ghc,- directory- -- websockets-0.9 is broken on Windows- if os(windows)- Build-Depends:- websockets >= 0.8 && < 0.9,- network < 2.6,- network-uri < 2.6- else- Build-Depends:- websockets >= 0.8,- network >= 2.6,- network-uri >= 2.6+ directory,+ websockets >= 0.9.1.0,+ network >= 2.6,+ network-uri >= 2.6 Default-Language: Haskell98
+ lib/Weak.js view
@@ -0,0 +1,15 @@+// "Weak Pointers". Mostly useless implementation since+// JS does its own GC.++function mkWeak(key, val, fin) {+ fin = !fin? function() {}: fin;+ return {key: key, val: val, fin: fin};+}++function derefWeak(w) {+ return [0, 1, E(w).val];+}++function finalizeWeak(w) {+ return [0, B(A(E(w).fin, [0]))];+}
lib/md5.js view
@@ -1,156 +1,157 @@ // Joseph Myers' MD5 implementation; used under the BSD license. function md5cycle(x, k) {-var a = x[0], b = x[1], c = x[2], d = x[3];+ var a = x[0], b = x[1], c = x[2], d = x[3]; -a = ff(a, b, c, d, k[0], 7, -680876936);-d = ff(d, a, b, c, k[1], 12, -389564586);-c = ff(c, d, a, b, k[2], 17, 606105819);-b = ff(b, c, d, a, k[3], 22, -1044525330);-a = ff(a, b, c, d, k[4], 7, -176418897);-d = ff(d, a, b, c, k[5], 12, 1200080426);-c = ff(c, d, a, b, k[6], 17, -1473231341);-b = ff(b, c, d, a, k[7], 22, -45705983);-a = ff(a, b, c, d, k[8], 7, 1770035416);-d = ff(d, a, b, c, k[9], 12, -1958414417);-c = ff(c, d, a, b, k[10], 17, -42063);-b = ff(b, c, d, a, k[11], 22, -1990404162);-a = ff(a, b, c, d, k[12], 7, 1804603682);-d = ff(d, a, b, c, k[13], 12, -40341101);-c = ff(c, d, a, b, k[14], 17, -1502002290);-b = ff(b, c, d, a, k[15], 22, 1236535329);+ a = ff(a, b, c, d, k[0], 7, -680876936);+ d = ff(d, a, b, c, k[1], 12, -389564586);+ c = ff(c, d, a, b, k[2], 17, 606105819);+ b = ff(b, c, d, a, k[3], 22, -1044525330);+ a = ff(a, b, c, d, k[4], 7, -176418897);+ d = ff(d, a, b, c, k[5], 12, 1200080426);+ c = ff(c, d, a, b, k[6], 17, -1473231341);+ b = ff(b, c, d, a, k[7], 22, -45705983);+ a = ff(a, b, c, d, k[8], 7, 1770035416);+ d = ff(d, a, b, c, k[9], 12, -1958414417);+ c = ff(c, d, a, b, k[10], 17, -42063);+ b = ff(b, c, d, a, k[11], 22, -1990404162);+ a = ff(a, b, c, d, k[12], 7, 1804603682);+ d = ff(d, a, b, c, k[13], 12, -40341101);+ c = ff(c, d, a, b, k[14], 17, -1502002290);+ b = ff(b, c, d, a, k[15], 22, 1236535329); -a = gg(a, b, c, d, k[1], 5, -165796510);-d = gg(d, a, b, c, k[6], 9, -1069501632);-c = gg(c, d, a, b, k[11], 14, 643717713);-b = gg(b, c, d, a, k[0], 20, -373897302);-a = gg(a, b, c, d, k[5], 5, -701558691);-d = gg(d, a, b, c, k[10], 9, 38016083);-c = gg(c, d, a, b, k[15], 14, -660478335);-b = gg(b, c, d, a, k[4], 20, -405537848);-a = gg(a, b, c, d, k[9], 5, 568446438);-d = gg(d, a, b, c, k[14], 9, -1019803690);-c = gg(c, d, a, b, k[3], 14, -187363961);-b = gg(b, c, d, a, k[8], 20, 1163531501);-a = gg(a, b, c, d, k[13], 5, -1444681467);-d = gg(d, a, b, c, k[2], 9, -51403784);-c = gg(c, d, a, b, k[7], 14, 1735328473);-b = gg(b, c, d, a, k[12], 20, -1926607734);+ a = gg(a, b, c, d, k[1], 5, -165796510);+ d = gg(d, a, b, c, k[6], 9, -1069501632);+ c = gg(c, d, a, b, k[11], 14, 643717713);+ b = gg(b, c, d, a, k[0], 20, -373897302);+ a = gg(a, b, c, d, k[5], 5, -701558691);+ d = gg(d, a, b, c, k[10], 9, 38016083);+ c = gg(c, d, a, b, k[15], 14, -660478335);+ b = gg(b, c, d, a, k[4], 20, -405537848);+ a = gg(a, b, c, d, k[9], 5, 568446438);+ d = gg(d, a, b, c, k[14], 9, -1019803690);+ c = gg(c, d, a, b, k[3], 14, -187363961);+ b = gg(b, c, d, a, k[8], 20, 1163531501);+ a = gg(a, b, c, d, k[13], 5, -1444681467);+ d = gg(d, a, b, c, k[2], 9, -51403784);+ c = gg(c, d, a, b, k[7], 14, 1735328473);+ b = gg(b, c, d, a, k[12], 20, -1926607734); -a = hh(a, b, c, d, k[5], 4, -378558);-d = hh(d, a, b, c, k[8], 11, -2022574463);-c = hh(c, d, a, b, k[11], 16, 1839030562);-b = hh(b, c, d, a, k[14], 23, -35309556);-a = hh(a, b, c, d, k[1], 4, -1530992060);-d = hh(d, a, b, c, k[4], 11, 1272893353);-c = hh(c, d, a, b, k[7], 16, -155497632);-b = hh(b, c, d, a, k[10], 23, -1094730640);-a = hh(a, b, c, d, k[13], 4, 681279174);-d = hh(d, a, b, c, k[0], 11, -358537222);-c = hh(c, d, a, b, k[3], 16, -722521979);-b = hh(b, c, d, a, k[6], 23, 76029189);-a = hh(a, b, c, d, k[9], 4, -640364487);-d = hh(d, a, b, c, k[12], 11, -421815835);-c = hh(c, d, a, b, k[15], 16, 530742520);-b = hh(b, c, d, a, k[2], 23, -995338651);+ a = hh(a, b, c, d, k[5], 4, -378558);+ d = hh(d, a, b, c, k[8], 11, -2022574463);+ c = hh(c, d, a, b, k[11], 16, 1839030562);+ b = hh(b, c, d, a, k[14], 23, -35309556);+ a = hh(a, b, c, d, k[1], 4, -1530992060);+ d = hh(d, a, b, c, k[4], 11, 1272893353);+ c = hh(c, d, a, b, k[7], 16, -155497632);+ b = hh(b, c, d, a, k[10], 23, -1094730640);+ a = hh(a, b, c, d, k[13], 4, 681279174);+ d = hh(d, a, b, c, k[0], 11, -358537222);+ c = hh(c, d, a, b, k[3], 16, -722521979);+ b = hh(b, c, d, a, k[6], 23, 76029189);+ a = hh(a, b, c, d, k[9], 4, -640364487);+ d = hh(d, a, b, c, k[12], 11, -421815835);+ c = hh(c, d, a, b, k[15], 16, 530742520);+ b = hh(b, c, d, a, k[2], 23, -995338651); -a = ii(a, b, c, d, k[0], 6, -198630844);-d = ii(d, a, b, c, k[7], 10, 1126891415);-c = ii(c, d, a, b, k[14], 15, -1416354905);-b = ii(b, c, d, a, k[5], 21, -57434055);-a = ii(a, b, c, d, k[12], 6, 1700485571);-d = ii(d, a, b, c, k[3], 10, -1894986606);-c = ii(c, d, a, b, k[10], 15, -1051523);-b = ii(b, c, d, a, k[1], 21, -2054922799);-a = ii(a, b, c, d, k[8], 6, 1873313359);-d = ii(d, a, b, c, k[15], 10, -30611744);-c = ii(c, d, a, b, k[6], 15, -1560198380);-b = ii(b, c, d, a, k[13], 21, 1309151649);-a = ii(a, b, c, d, k[4], 6, -145523070);-d = ii(d, a, b, c, k[11], 10, -1120210379);-c = ii(c, d, a, b, k[2], 15, 718787259);-b = ii(b, c, d, a, k[9], 21, -343485551);+ a = ii(a, b, c, d, k[0], 6, -198630844);+ d = ii(d, a, b, c, k[7], 10, 1126891415);+ c = ii(c, d, a, b, k[14], 15, -1416354905);+ b = ii(b, c, d, a, k[5], 21, -57434055);+ a = ii(a, b, c, d, k[12], 6, 1700485571);+ d = ii(d, a, b, c, k[3], 10, -1894986606);+ c = ii(c, d, a, b, k[10], 15, -1051523);+ b = ii(b, c, d, a, k[1], 21, -2054922799);+ a = ii(a, b, c, d, k[8], 6, 1873313359);+ d = ii(d, a, b, c, k[15], 10, -30611744);+ c = ii(c, d, a, b, k[6], 15, -1560198380);+ b = ii(b, c, d, a, k[13], 21, 1309151649);+ a = ii(a, b, c, d, k[4], 6, -145523070);+ d = ii(d, a, b, c, k[11], 10, -1120210379);+ c = ii(c, d, a, b, k[2], 15, 718787259);+ b = ii(b, c, d, a, k[9], 21, -343485551); -x[0] = add32(a, x[0]);-x[1] = add32(b, x[1]);-x[2] = add32(c, x[2]);-x[3] = add32(d, x[3]);+ x[0] = add32(a, x[0]);+ x[1] = add32(b, x[1]);+ x[2] = add32(c, x[2]);+ x[3] = add32(d, x[3]); } function cmn(q, a, b, x, s, t) {-a = add32(add32(a, q), add32(x, t));-return add32((a << s) | (a >>> (32 - s)), b);+ a = add32(add32(a, q), add32(x, t));+ return add32((a << s) | (a >>> (32 - s)), b); } function ff(a, b, c, d, x, s, t) {-return cmn((b & c) | ((~b) & d), a, b, x, s, t);+ return cmn((b & c) | ((~b) & d), a, b, x, s, t); } function gg(a, b, c, d, x, s, t) {-return cmn((b & d) | (c & (~d)), a, b, x, s, t);+ return cmn((b & d) | (c & (~d)), a, b, x, s, t); } function hh(a, b, c, d, x, s, t) {-return cmn(b ^ c ^ d, a, b, x, s, t);+ return cmn(b ^ c ^ d, a, b, x, s, t); } function ii(a, b, c, d, x, s, t) {-return cmn(c ^ (b | (~d)), a, b, x, s, t);+ return cmn(c ^ (b | (~d)), a, b, x, s, t); } function md51(s) {-var n = s.length,-state = [1732584193, -271733879, -1732584194, 271733878], i;-for (i=64; i<=s.length; i+=64) {-md5cycle(state, md5blk(s.substring(i-64, i)));-}-s = s.substring(i-64);-var tail = [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0];-for (i=0; i<s.length; i++)-tail[i>>2] |= s.charCodeAt(i) << ((i%4) << 3);-tail[i>>2] |= 0x80 << ((i%4) << 3);-if (i > 55) {-md5cycle(state, tail);-for (i=0; i<16; i++) tail[i] = 0;-}-tail[14] = n*8;-md5cycle(state, tail);-return state;+ var n = s.length,+ state = [1732584193, -271733879, -1732584194, 271733878], i;+ for (i=64; i<=s.length; i+=64) {+ md5cycle(state, md5blk(s.substring(i-64, i)));+ }+ s = s.substring(i-64);+ var tail = [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0];+ for (i=0; i<s.length; i++)+ tail[i>>2] |= s.charCodeAt(i) << ((i%4) << 3);+ tail[i>>2] |= 0x80 << ((i%4) << 3);+ if (i > 55) {+ md5cycle(state, tail);+ for (i=0; i<16; i++) tail[i] = 0;+ }+ tail[14] = n*8;+ md5cycle(state, tail);+ return state; }+window['md51'] = md51; function md5blk(s) {-var md5blks = [], i;-for (i=0; i<64; i+=4) {-md5blks[i>>2] = s.charCodeAt(i)-+ (s.charCodeAt(i+1) << 8)-+ (s.charCodeAt(i+2) << 16)-+ (s.charCodeAt(i+3) << 24);-}-return md5blks;+ var md5blks = [], i;+ for (i=0; i<64; i+=4) {+ md5blks[i>>2] = s.charCodeAt(i)+ + (s.charCodeAt(i+1) << 8)+ + (s.charCodeAt(i+2) << 16)+ + (s.charCodeAt(i+3) << 24);+ }+ return md5blks; } var hex_chr = '0123456789abcdef'.split(''); function rhex(n) {-var s='', j=0;-for(; j<4; j++)-s += hex_chr[(n >> (j * 8 + 4)) & 0x0F]-+ hex_chr[(n >> (j * 8)) & 0x0F];-return s;+ var s='', j=0;+ for(; j<4; j++)+ s += hex_chr[(n >> (j * 8 + 4)) & 0x0F]+ + hex_chr[(n >> (j * 8)) & 0x0F];+ return s; } function hex(x) {-for (var i=0; i<x.length; i++)-x[i] = rhex(x[i]);-return x.join('');+ for (var i=0; i<x.length; i++)+ x[i] = rhex(x[i]);+ return x.join(''); } function md5(s) {-return hex(md51(s));+ return hex(md51(s)); } function add32(a, b) {-return (a + b) & 0xFFFFFFFF;+ return (a + b) & 0xFFFFFFFF; }
lib/rts.js view
@@ -3,15 +3,13 @@ /* Thunk Creates a thunk representing the given closure.- Since we want automatic memoization of as many expressions as possible, we- use a JS object as a sort of tagged pointer, where the member x denotes the- object actually pointed to. If a "pointer" points to a thunk, it has a- member 't' which is set to true; if it points to a value, be it a function,- a value of an algebraic type of a primitive value, it has no member 't'.+ If the non-updatable flag is undefined, the thunk is updatable. */--function T(f) {+function T(f, nu) { this.f = f;+ if(nu === undefined) {+ this.x = __updatable;+ } } function F(f) {@@ -21,6 +19,9 @@ // Special object used for blackholing. var __blackhole = {}; +// Used to indicate that an object is updatable.+var __updatable = {};+ /* Apply Applies the function f to the arguments args. If the application is under- saturated, a closure is returned, awaiting further arguments. If it is over-@@ -71,10 +72,14 @@ */ function E(t) { if(t instanceof T) {- if(t.f != __blackhole) {+ if(t.f !== __blackhole) { var f = t.f; t.f = __blackhole;- t.x = f();+ if(t.x === __updatable) {+ t.x = f();+ } else {+ return f();+ } } return t.x; } else {@@ -88,7 +93,7 @@ function B(f) { while(f instanceof F) { var fun = f.f;- f = __blackhole;+ f.f = __blackhole; f = fun(); } return f;@@ -323,7 +328,13 @@ } var __word_encodeFloat = __word_encodeDouble;-var jsRound = Math.round; // Stupid GHC doesn't like periods in FFI IDs...+var jsRound = Math.round;+var jsTrunc = Math.trunc ? Math.trunc : function(x) {+ return x < 0 ? Math.ceil(x) : Math.floor(x);+};+function jsRoundW(n) {+ return Math.abs(jsTrunc(n));+} var realWorld = undefined; if(typeof _ == 'undefined') { var _ = undefined;
lib/stdlib.js view
@@ -94,7 +94,18 @@ case 'keyup': case 'keydown': fun = function(x) {B(A(cb,[[0,x.keyCode],0]));};- break; + break;+ case 'wheel':+ fun = function(x) {+ var mpos = jsGetMouseCoords(x);+ var mx = [0,mpos[0]];+ var my = [0,mpos[1]];+ var mdx = [0,x.deltaX];+ var mdy = [0,x.deltaY];+ var mdz = [0,x.deltaZ];+ B(A(cb,[[0,mx,my],[0,mdx,mdy,mdz],0]));+ };+ break; default: fun = function() {B(A(cb,[0]));}; break;@@ -163,22 +174,30 @@ return [0]; } -function jsQuerySelectorAll(elem, query) {- var els = [0],- len, nl, i;+function jsElemsByClassName(cls) {+ var es = document.getElementsByClassName(cls);+ var els = [0]; - if (!elem || typeof elem.querySelectorAll !== 'function') {+ for (var i = es.length-1; i >= 0; --i) {+ els = [1, [0, es[i]], els];+ } return els;- }+} - nl = elem.querySelectorAll(query);- len = nl.length;+function jsQuerySelectorAll(elem, query) {+ var els = [0], nl; - for (i=len-1; i >= 0; --i) {- els = [1, [0, nl[i]], els];- }+ if (!elem || typeof elem.querySelectorAll !== 'function') {+ return els;+ } - return els;+ nl = elem.querySelectorAll(query);++ for (var i = nl.length-1; i >= 0; --i) {+ els = [1, [0, nl[i]], els];+ }++ return els; } function jsCreateElem(tag) {@@ -292,7 +311,7 @@ case 'number': return [0, [0, jsRead(obj)]]; case 'string':- return [1, [0, obj]];+ return [1, obj]; break; case 'boolean': return [2, obj]; // Booleans are special wrt constructor tags!@@ -326,7 +345,7 @@ if(elem >= arr.length) { return [0]; }- return [1, toHS(arr[elem]), new T(function() {return arr2lst_json(arr,elem+1);})]+ return [1, toHS(arr[elem]), new T(function() {return arr2lst_json(arr,elem+1);}),true] } function arr2lst(arr, elem) {@@ -335,6 +354,7 @@ } return [1, arr[elem], new T(function() {return arr2lst(arr,elem+1);})] }+window['arr2lst'] = arr2lst; function lst2arr(xs) { var arr = [];@@ -343,6 +363,7 @@ } return arr; }+window['lst2arr'] = lst2arr; function ajaxReq(method, url, async, postdata, cb) { var xhr = new XMLHttpRequest();
libraries/haste-lib/src/Haste.hs view
@@ -1,4 +1,9 @@ {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, CPP #-}+-- | Haste's companion to the Prelude.+--+-- Note that this module should *not* be imported together with+-- "Haste.App", which provides the same functionality but slightly modified+-- for automatic program slicing. module Haste ( JSString, JSAny, URL, CB.GenericCallback, alert, prompt, eval, writeLog, catJSStr, fromJSStr,
libraries/haste-lib/src/Haste/App.hs view
@@ -1,7 +1,9 @@ -- | Type-safe client-server communication framework for Haste.--- This module re-exports most of the Haste module for convenience since some--- functions are exported by both Haste and Haste.App with different--- definitions. For simplicity, import one or the other, not both.+--+-- In addition to the Haste.App extras, this module exports the same API as+-- "Haste", modified slightly to work better with the automatic program+-- slicing Haste.App provides. This means that you should import either this+-- module *or* Haste, but *not* both. module Haste.App ( MonadIO, Remotable, App, Server, Remote, Done, Sessions, SessionID,
libraries/haste-lib/src/Haste/App/Monad.hs view
@@ -19,6 +19,7 @@ import Control.Concurrent (ThreadId) import Data.IORef import Data.Default+import System.IO.Unsafe #ifndef __HASTE__ import Haste.Binary.Types import Control.Concurrent (forkIO)@@ -62,6 +63,10 @@ data Remote a = Remote #endif +-- | Has 'runApp' already been invoked?+hasteAppRunning :: IORef Bool+hasteAppRunning = unsafePerformIO $ newIORef False+ -- | Apply an exported function to an argument. -- TODO: look into making this Applicative. (<.>) :: Binary a => Remote (a -> b) -> a -> Remote b@@ -183,19 +188,24 @@ -- | Run a Haste.App application. runApp never returns before the program -- terminates. ----- Note that @runApp@'s arguments *must not* depend on any external IO,--- or the client and server computations may diverge.--- Ideally, calling runApp should be the first and only thing that happens--- in main.+-- Note that @runApp@ is single-entry, and that its argument must not+-- depend on any external IO. It is *strongly* recommended that the main+-- function of any Haste.App program *only* consists of a single call to+-- @runApp@. runApp :: AppCfg -> App Done -> IO () runApp cfg (App s) = do+ running <- atomicModifyIORef hasteAppRunning $ \r -> (True, r)+ if running+ then do+ error "runApp is single-entry!"+ else do #ifdef __HASTE__- (Done client, _, _, _) <- s cfg undefined 0 undefined- client+ (Done client, _, _, _) <- s cfg undefined 0 undefined+ client #else- sessions <- newIORef S.empty- (_, _, exports, cfg') <- s cfg sessions 0 M.empty- serverEventLoop cfg' sessions exports+ sessions <- newIORef S.empty+ (_, _, exports, cfg') <- s cfg sessions 0 M.empty+ serverEventLoop cfg' sessions exports #endif #ifndef __HASTE__@@ -233,7 +243,7 @@ srResult = result } sendBinaryData c bs- Left e -> do+ _ -> do error $ "Got bad method call: " ++ show msg go #endif
libraries/haste-lib/src/Haste/Binary.hs view
@@ -220,13 +220,13 @@ instance ( GSum a, GSum b , GBinary a, GBinary b , SumSize a, SumSize b) => GBinary (a :+: b) where- gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) -- | PUTSUM(Word64)+ gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) -- | PUTSUM(Word64) | otherwise = sizeError "encode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word32) {-# INLINE gput #-} - gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) -- | GETSUM(Word64)+ gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) -- | GETSUM(Word64) | otherwise = sizeError "decode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word32)
libraries/haste-lib/src/Haste/Callback.hs view
@@ -88,6 +88,8 @@ OnKeyPress :: Event m (Int -> m ()) OnKeyUp :: Event m (Int -> m ()) OnKeyDown :: Event m (Int -> m ())+ OnSubmit :: Event m (m ())+ OnWheel :: Event m ((Int, Int) -> (Double, Double, Double) -> m ()) asEvtTypeOf :: Event m a -> a -> a asEvtTypeOf _ = id@@ -117,6 +119,8 @@ OnChange -> "change" OnFocus -> "focus" OnBlur -> "blur"+ OnSubmit -> "submit"+ OnWheel -> "wheel" -- | Friendlier name for @setCallback@. onEvent :: MonadIO m => Elem -> Event IO a -> a -> m Bool
libraries/haste-lib/src/Haste/DOM.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP, GeneralizedNewtypeDeriving #-} module Haste.DOM (- Elem (..), PropID, ElemID,+ Elem (..), PropID, ElemID, QuerySelector, ElemClass,+ Attribute, AttrName, AttrValue,+ set, style, attr, with, (=:), newElem, newTextElem,- elemById, elemsByQS,+ elemById, elemsByQS, elemsByClass, setProp, getProp, setAttr, getAttr, setProp', getProp', getValue, withElem , withElems, withElemsQS, mapQS, mapQS_, addChild, addChildBefore, removeChild, clearChildren , getChildBefore,@@ -21,6 +23,7 @@ import Haste.Foreign import Haste.Binary.Types import System.IO.Unsafe (unsafePerformIO)+import qualified Data.String as S newtype Elem = Elem JSAny deriving (Pack, Unpack)@@ -28,7 +31,21 @@ type PropID = String type ElemID = String type QuerySelector = String+type ElemClass = String+type AttrValue = String +-- | Create a style attribute name.+style :: String -> AttrName+style = StyleName . toJSStr++-- | Create an HTML attribute name.+attr :: String -> AttrName+attr = AttrName . toJSStr++-- | Create an 'Attribute'.+(=:) :: AttrName -> AttrValue -> Attribute+name =: val = attribute name (toJSStr val)+ #ifdef __HASTE__ foreign import ccall jsGet :: Elem -> JSString -> IO JSString foreign import ccall jsSet :: Elem -> JSString -> JSString -> IO ()@@ -38,6 +55,7 @@ foreign import ccall jsSetStyle :: Elem -> JSString -> JSString -> IO () foreign import ccall jsFind :: JSString -> IO (Ptr (Maybe Elem)) foreign import ccall jsQuerySelectorAll :: Elem -> JSString -> IO (Ptr [Elem])+foreign import ccall jsElemsByClassName :: JSString -> IO (Ptr [Elem]) foreign import ccall jsCreateElem :: JSString -> IO Elem foreign import ccall jsCreateTextNode :: JSString -> IO Elem foreign import ccall jsAppendChild :: Elem -> Elem -> IO ()@@ -57,6 +75,7 @@ jsGetStyle = error "Tried to use jsGetStyle on server side!" jsSetStyle = error "Tried to use jsSetStyle on server side!" jsFind = error "Tried to use jsFind on server side!"+jsElemsByClassName = error "Tried to use jsElemsByClassName on server side!" jsQuerySelectorAll = error "Tried to use jsQuerySelectorAll on server side!" jsCreateElem = error "Tried to use jsCreateElem on server side!" jsCreateTextNode = error "Tried to use jsCreateTextNode on server side!"@@ -161,6 +180,10 @@ elemById :: MonadIO m => ElemID -> m (Maybe Elem) elemById eid = liftIO $ fromPtr `fmap` (jsFind $ toJSStr eid) +-- | Get all elements of the given class.+elemsByClass :: MonadIO m => ElemClass -> m [Elem]+elemsByClass cls = liftIO $ fromPtr `fmap` (jsElemsByClassName (toJSStr cls))+ -- | Get all children elements matching a query selector. elemsByQS :: MonadIO m => Elem -> QuerySelector -> m [Elem] elemsByQS el sel = liftIO $ fromPtr `fmap` (jsQuerySelectorAll el (toJSStr sel))@@ -298,3 +321,44 @@ {-# NOINLINE getBody #-} getBody :: IO Elem getBody = ffi "document.body"++-- | The name of an attribute. May be either a common property, an HTML+-- attribute or a style attribute.+data AttrName+ = PropName JSString+ | StyleName JSString+ | AttrName JSString++instance S.IsString AttrName where+ fromString = PropName . S.fromString++-- | A key/value pair representing the value of an attribute.+-- May represent a property, an HTML attribute or a style attribute.+data Attribute = Attribute AttrName JSString++-- | Construct an 'Attribute'.+attribute :: AttrName -> JSString -> Attribute+attribute = Attribute++-- | Set a number of 'Attribute's on an element.+set :: MonadIO m => Elem -> [Attribute] -> m ()+set e as =+ liftIO $ mapM_ set' as+ where+ set' (Attribute (PropName k) v) = jsSet e k v+ set' (Attribute (StyleName k) v) = jsSetStyle e k v+ set' (Attribute (AttrName k) v) = jsSetAttr e k v++-- | Set a number of 'Attribute's on the element produced by an IO action.+-- Gives more convenient syntax when creating elements:+--+-- newElem "div" `with` [+-- style "border" := "1px solid black",+-- ...+-- ]+--+with :: MonadIO m => m Elem -> [Attribute] -> m Elem+with m attrs = do+ x <- m+ set x attrs+ return x
libraries/haste-lib/src/Haste/Graphics/Canvas.hs view
@@ -1,21 +1,22 @@ {-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, TypeSynonymInstances, FlexibleInstances, GADTs, CPP, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- | Basic Canvas graphics library. module Haste.Graphics.Canvas ( -- Types Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..),- AnyImageBuffer (..),+ Ctx, AnyImageBuffer (..), -- Classes ImageBuffer (..), BitmapSource (..), -- Obtaining a canvas for drawing- getCanvasById, getCanvas, createCanvas,+ getCanvasById, getCanvas, createCanvas, canvasElem, -- Working with bitmaps bitmapElem, -- Rendering pictures, extracting data from a canvas render, renderOnTop, buffer, toDataURL, -- Working with colors and opacity- setStrokeColor, setFillColor, color, opacity,+ setStrokeColor, setFillColor, color, opacity, lineWidth, -- Matrix operations translate, scale, rotate, -- Using shapes@@ -62,6 +63,27 @@ -> IO () foreign import ccall jsCanvasToDataURL :: Elem -> IO JSString #else+jsHasCtx2D :: Elem -> IO Bool+jsGetCtx2D :: Elem -> IO Ctx+jsBeginPath :: Ctx -> IO ()+jsMoveTo :: Ctx -> Double -> Double -> IO ()+jsLineTo :: Ctx -> Double -> Double -> IO ()+jsStroke :: Ctx -> IO ()+jsFill :: Ctx -> IO ()+jsRotate :: Ctx -> Double -> IO ()+jsTranslate :: Ctx -> Double -> Double -> IO ()+jsScale :: Ctx -> Double -> Double -> IO ()+jsPushState :: Ctx -> IO ()+jsPopState :: Ctx -> IO ()+jsResetCanvas :: Elem -> IO ()+jsDrawImage :: Ctx -> Elem -> Double -> Double -> IO ()+jsDrawImageClipped :: Ctx -> Elem -> Double -> Double+ -> Double -> Double -> Double -> Double + -> IO ()+jsDrawText :: Ctx -> JSString -> Double -> Double -> IO ()+jsClip :: Ctx -> IO ()+jsArc :: Ctx -> Double -> Double -> Double -> Double -> Double -> IO ()+jsCanvasToDataURL :: Elem -> IO JSString jsHasCtx2D = error "Tried to use Canvas in native code!" jsGetCtx2D = error "Tried to use Canvas in native code!" jsBeginPath = error "Tried to use Canvas in native code!"@@ -114,7 +136,7 @@ instance BitmapSource URL where loadBitmap url = liftIO $ do img <- newElem "img"- setProp img "src" url+ setProp' img "src" (toJSString url) loadBitmap img instance BitmapSource Elem where@@ -127,6 +149,10 @@ draw (AnyImageBuffer buf) = draw buf drawClipped (AnyImageBuffer buf) = drawClipped buf +-- | Get the DOM node backing a given canvas.+canvasElem :: Canvas -> Elem+canvasElem (Canvas _ctx e) = e+ -- | Get the HTML element associated with the given bitmap. bitmapElem :: Bitmap -> Elem bitmapElem (Bitmap e) = e@@ -141,15 +167,15 @@ type Angle = Double -- | A rectangle.-data Rect = Rect {rect_x :: Double,- rect_y :: Double,- rect_w :: Double,- rect_h :: Double}+data Rect = Rect {rect_x :: !Double,+ rect_y :: !Double,+ rect_w :: !Double,+ rect_h :: !Double} -- | A color, specified using its red, green and blue components, with an -- optional alpha component.-data Color = RGB Int Int Int- | RGBA Int Int Int Double+data Color = RGB !Int !Int !Int+ | RGBA !Int !Int !Int !Double -- | Somewhat efficient conversion from Color to JSString. color2JSString :: Color -> JSString@@ -170,7 +196,7 @@ -- The origin of the coordinate system used by the canvas is the top left -- corner of the canvas element. -- JS representation is a reference to the backing canvas element.-data Canvas = Canvas Ctx Elem+data Canvas = Canvas !Ctx !Elem instance Pack Canvas where pack c =@@ -243,8 +269,8 @@ createCanvas :: Int -> Int -> IO (Maybe Canvas) createCanvas w h = do buf <- newElem "canvas"- setProp buf "width" (toString w)- setProp buf "height" (toString h)+ setProp' buf "width" (toJSString w)+ setProp' buf "height" (toJSString h) getCanvas buf -- | Clear a canvas, then draw a picture onto it.@@ -259,7 +285,7 @@ {-# SPECIALISE renderOnTop :: Canvas -> Picture a -> IO a #-} {-# SPECIALISE renderOnTop :: Canvas -> Picture a -> CIO a #-} renderOnTop :: MonadIO m => Canvas -> Picture a -> m a-renderOnTop (Canvas ctx el) (Picture p) = liftIO $ p ctx+renderOnTop (Canvas ctx _) (Picture p) = liftIO $ p ctx -- | Generate a data URL from the contents of a canvas. toDataURL :: MonadIO m => Canvas -> m URL@@ -314,6 +340,14 @@ setProp' (Elem ctx) "strokeStyle" sc where c' = color2JSString c++-- | Draw the given picture using a new line width.+lineWidth :: Double -> Picture () -> Picture ()+lineWidth w (Picture pict) = Picture $ \(Ctx ctx) -> do+ lw <- getProp' (Elem ctx) "lineWidth"+ setProp' (Elem ctx) "lineWidth" (toJSString w)+ pict (Ctx ctx)+ setProp' (Elem ctx) "lineWidth" lw -- | Draw the specified picture using the given point as the origin. translate :: Vector -> Picture () -> Picture ()
libraries/haste-lib/src/Haste/JSON.hs view
@@ -32,11 +32,11 @@ -- Remember to update jsParseJSON if this data type changes! data JSON- = Num Double- | Str JSString- | Bool Bool- | Arr [JSON]- | Dict [(JSString, JSON)]+ = Num !Double+ | Str !JSString+ | Bool !Bool+ | Arr ![JSON]+ | Dict ![(JSString, JSON)] | Null instance IsString JSON where
libraries/haste-lib/src/Haste/JSType.hs view
@@ -26,11 +26,16 @@ toNumber :: a -> Double fromNumber :: Double -> a +instance JSType JSString where+ toJSString = id+ fromJSString = Just+ #ifdef __HASTE__ foreign import ccall "Number" jsNumber :: JSString -> Double foreign import ccall "String" jsString :: Double -> JSString-foreign import ccall jsRound :: Double -> Int+foreign import ccall jsTrunc :: Double -> Int+foreign import ccall jsTruncW :: Double -> Int foreign import ccall "I_toInt" jsIToInt :: ByteArray# -> Int foreign import ccall "I_toString" jsIToString :: ByteArray# -> JSString foreign import ccall "I_fromString" jsStringToI :: JSString -> ByteArray#@@ -43,12 +48,18 @@ unsafeIntFromJSString s = case jsNumber s of d | isNaN d -> Nothing- | otherwise -> Just (unsafeCoerce# (jsRound d))+ | otherwise -> Just (unsafeCoerce# (jsTrunc d)) +unsafeWordFromJSString :: JSString -> Maybe a+unsafeWordFromJSString s =+ case jsNumber s of+ d | isNaN d -> Nothing+ | otherwise -> Just (unsafeCoerce# (jsTruncW d))+ -- JSNum instances instance JSNum Int where- fromNumber = unsafeCoerce# jsRound+ fromNumber = unsafeCoerce# jsTrunc toNumber = unsafeCoerce# instance JSNum Int8 where@@ -60,12 +71,12 @@ toNumber = unsafeCoerce# instance JSNum Int32 where- fromNumber = unsafeCoerce# jsRound+ fromNumber = unsafeCoerce# jsTrunc toNumber = unsafeCoerce# instance JSNum Word where fromNumber n =- case jsRound (unsafeCoerce# n) of+ case jsTrunc (unsafeCoerce# n) of I# n' -> W# (int2Word# n') toNumber = unsafeCoerce# @@ -110,16 +121,16 @@ fromJSString = unsafeIntFromJSString instance JSType Word where toJSString = unsafeToJSString- fromJSString = unsafeIntFromJSString+ fromJSString = unsafeWordFromJSString instance JSType Word8 where toJSString = unsafeToJSString- fromJSString = unsafeIntFromJSString+ fromJSString = unsafeWordFromJSString instance JSType Word16 where toJSString = unsafeToJSString- fromJSString = unsafeIntFromJSString+ fromJSString = unsafeWordFromJSString instance JSType Word32 where toJSString = unsafeToJSString- fromJSString = unsafeIntFromJSString+ fromJSString = unsafeWordFromJSString instance JSType Float where fromJSString s =
src/Data/JSTarget/AST.hs view
@@ -94,7 +94,7 @@ AssignEx :: !Exp -> !Exp -> Exp IfEx :: !Exp -> !Exp -> !Exp -> Exp Eval :: !Exp -> Exp- Thunk :: !Stm -> Exp+ Thunk :: !Bool -> !Stm -> Exp -- Thunk may be updatable or not deriving (Eq, Show) -- | Statements. The only mildly interesting thing here are the Case and Jump
src/Data/JSTarget/Binary.hs view
@@ -63,7 +63,7 @@ put (AssignEx l r) = putWord8 8 >> put l >> put r put (IfEx c th el) = putWord8 9 >> put c >> put th >> put el put (Eval x) = putWord8 10 >> put x- put (Thunk x) = putWord8 11 >> put x+ put (Thunk upd x) = putWord8 11 >> put upd >> put x get = do tag <- getWord8@@ -79,7 +79,7 @@ 8 -> AssignEx <$> get <*> get 9 -> IfEx <$> get <*> get <*> get 10 -> Eval <$> get- 11 -> Thunk <$> get+ 11 -> Thunk <$> get <*> get n -> error $ "Bad tag in get :: Get Exp: " ++ show n instance Binary Stm where
src/Data/JSTarget/Constructors.hs view
@@ -95,8 +95,8 @@ newVar i = Internal (Name (prefix ++ show i) Nothing) "" -- | Create a thunk.-thunk :: AST Stm -> AST Exp-thunk = fmap Thunk+thunk :: Bool -> AST Stm -> AST Exp+thunk updatable = fmap (Thunk updatable) -- | Evaluate an expression that may or may not be a thunk. eval :: AST Exp -> AST Exp
src/Data/JSTarget/Optimize.hs view
@@ -174,7 +174,7 @@ opt (Call _ _ (Var (Foreign "toJSStr")) [ Eval (Call _ _ (Var (Foreign "unCStr")) [x])]) = return x- opt (Thunk (Return x@(Call _ _ (Var (Foreign "unCStr")) [Lit _]))) =+ opt (Thunk _ (Return x@(Call _ _ (Var (Foreign "unCStr")) [Lit _]))) = return x opt x = return x@@ -207,8 +207,8 @@ -- | Unpack the given expression if it's a thunk. fromThunk :: Exp -> Maybe Stm-fromThunk (Thunk body) = Just body-fromThunk _ = Nothing+fromThunk (Thunk _ body) = Just body+fromThunk _ = Nothing -- | Unpack the given expression if it's a thunk without internal bindings. fromThunkEx :: Exp -> Maybe Exp@@ -234,7 +234,7 @@ Var _ -> False Lit _ -> False Fun _ _ _ -> False- Thunk _ -> False+ Thunk _ _ -> False Arr arr -> any computingEx arr _ -> True @@ -259,13 +259,19 @@ pure m -- | May the given expression ever tailcall?+-- TODO:+-- Be slightly smarter about handling locally defined functions; always+-- counting a tailcall from a local as a tailcall from the containing+-- function seems a bit too restrictive. On the other hand, this makes+-- only a very slight difference in the number of unnecessary tailcalls+-- eliminated. mayTailcall :: JSTrav ast => ast -> TravM Bool mayTailcall ast = do foldJS enter countTCs False ast where enter True _ = False- enter _ (Exp (Thunk _)) = False- enter _ (Exp (Fun _ _ _)) = False+ enter _ (Exp (Thunk _ _)) = False+-- enter _ (Exp (Fun _ _ _)) = False enter _ _ = True countTCs _ (Stm (Tailcall _)) = return True countTCs acc _ = return acc@@ -466,7 +472,7 @@ -- Only traverse until we find a closure createsClosures = foldJS (\acc _ -> not acc) isClosure False isClosure _ (Exp (Fun _ _ _)) = pure True- isClosure _ (Exp (Thunk _)) = pure True+ isClosure _ (Exp (Thunk _ _)) = pure True isClosure acc _ = pure acc -- Assign any changed vars, then loop.@@ -502,6 +508,6 @@ contains (AssignEx l r) var = l `contains` var || r `contains` var contains (IfEx c t e) var = any (`contains` var) [c,t,e] contains (Eval x) var = x `contains` var- contains (Thunk _) _ = False+ contains (Thunk _ _) _ = False tailLoopify _ fun = do return fun
src/Data/JSTarget/Print.hs view
@@ -108,11 +108,17 @@ pp c .+. sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el pp (Eval x) = do "E(" .+. pp x .+. ")"- pp (Thunk x) = do+ pp (Thunk True x) = do "new T(function(){" .+. newl .+. indent (pp x) .+. "})"+ pp (Thunk False x) = do+ "new T(function(){" .+. newl .+. indent (pp x) .+. "},1)" instance Pretty (Var, Exp) where pp (v, ex) = pp v .+. sp .+. "=" .+. sp .+. pp ex++instance Pretty Bool where+ pp True = "true"+ pp False = "false" -- | Print a series of NewVars at once, to avoid unnecessary "var" keywords. ppAssigns :: Stm -> PP ()
src/Data/JSTarget/Traversal.hs view
@@ -110,8 +110,8 @@ return (acc''', IfEx c' th' el') Eval x -> do fmap Eval <$> mapEx acc x- Thunk x -> do- fmap Thunk <$> foldMapJS tr fe fs acc x+ Thunk upd x -> do+ fmap (Thunk upd) <$> foldMapJS tr fe fs acc x else do return (acc, ast) fe acc' x@@ -151,7 +151,7 @@ foldJS tr f acc'' el Eval ex -> do foldJS tr f acc ex- Thunk stm -> do+ Thunk upd stm -> do foldJS tr f acc stm else do return acc@@ -264,6 +264,8 @@ go s@(Return _) = return s go (Cont) = return Cont go (NullRet) = return NullRet+ go s@(Tailcall _) = return s+ go s@(ThunkRet _) = return s -- | Returns statement's returned expression, if any. finalExp :: Stm -> TravM (Maybe Exp)@@ -292,7 +294,7 @@ -- | Thunks and explicit lambdas count as lambda abstractions. isLambda :: ASTNode -> Bool isLambda (Exp (Fun _ _ _)) = True-isLambda (Exp (Thunk _)) = True+isLambda (Exp (Thunk _ _)) = True isLambda _ = False isJump :: ASTNode -> Bool
src/Haste/CodeGen.hs view
@@ -216,7 +216,7 @@ -- Constructors are never partially applied, and we have arguments, so this -- is obviously a full application. if recursive- then thunk . ret <$> genEx (StgConApp con args)+ then thunk True . ret <$> genEx (StgConApp con args) else genEx (StgConApp con args) genRhs _ (StgRhsClosure _ _ _ upd _ args body) = do args' <- mapM genVar args@@ -224,11 +224,13 @@ mapM_ addLocal args' genEx body return $ if null args- then thunk' (body' $ thunkRet retExp)+ then thunk' upd (body' $ thunkRet retExp) else fun args' (body' $ ret retExp) where- thunk' (AST (Return l@(Lit _)) js) = AST l js- thunk' stm = thunk stm+ thunk' _ (AST (Return l@(Lit _)) js) = AST l js+ thunk' Updatable stm = thunk True stm+ thunk' ReEntrant stm = thunk True stm+ thunk' SingleEntry stm = thunk False stm -- | Turn a recursive binding into a list of non-recursive ones, together with -- information about whether they came from a recursive group or not.
src/Haste/Config.hs view
@@ -18,7 +18,7 @@ stdJSLibs = map (jsDir </>) [ "rts.js", "stdlib.js", "MVar.js", "StableName.js", "Integer.js", "Int64.js", "md5.js", "array.js", "pointers.js", "cheap-unicode.js", "Canvas.js",- "Handle.js"+ "Handle.js", "Weak.js" ] debugLib :: FilePath
src/Haste/Environment.hs view
@@ -1,24 +1,26 @@ {-# LANGUAGE CPP #-} -- | Paths, host bitness and other environmental information about Haste. module Haste.Environment (- hasteSysDir, jsmodSysDir, hasteInstSysDir, pkgSysDir, pkgSysLibDir, jsDir,- hasteUserDir, jsmodUserDir, hasteInstUserDir, pkgUserDir, pkgUserLibDir,- hostWordSize, ghcLibDir,- ghcBinary, ghcPkgBinary,- hasteBinary, hastePkgBinary, hasteInstHisBinary, hasteInstBinary,- hasteCopyPkgBinary, closureCompiler, portableHaste) where+ hasteSysDir, jsmodSysDir, hasteInstSysDir, pkgSysDir, pkgSysLibDir, jsDir,+ hasteUserDir, jsmodUserDir, hasteInstUserDir, pkgUserDir, pkgUserLibDir,+ hostWordSize, ghcLibDir,+ ghcBinary, ghcPkgBinary,+ hasteBinary, hastePkgBinary, hasteInstHisBinary, hasteInstBinary,+ hasteCopyPkgBinary, closureCompiler, portableHaste,+ needsReboot, bootFile+ ) where import System.IO.Unsafe import Data.Bits import Foreign.C.Types (CIntPtr)-import Control.Shell-import System.Environment (getExecutablePath)-import System.Directory (findExecutable)+import Control.Shell hiding (hClose) import Paths_haste_compiler-import GHC.Paths (libdir)-import Config (cProjectVersion)-import Data.Maybe (catMaybes)+import System.IO+import System.Environment (getExecutablePath)+import Haste.GHCPaths (ghcBinary, ghcPkgBinary, ghcLibDir)+import Haste.Version #if defined(PORTABLE)+-- | Was Haste built in portable mode or not? portableHaste :: Bool portableHaste = True @@ -28,38 +30,39 @@ hasteSysDir = joinPath . init . init . splitPath $ unsafePerformIO getExecutablePath -ghcLibDir :: FilePath-ghcLibDir = unsafePerformIO $ do- Right out <- shell $ run ghcBinary ["--print-libdir"] ""- return $ init out-+-- | Haste @bin@ directory. hasteBinDir :: FilePath hasteBinDir = hasteSysDir </> "bin" +-- | Haste JS file directory. jsDir :: FilePath jsDir = hasteSysDir </> "js"+ #else++-- | Was Haste built in portable mode or not? portableHaste :: Bool portableHaste = False --- | Haste system directory. Identical to @hasteUserDir@ unless built with+-- | Haste system directory. Identical to 'hasteUserDir' unless built with -- -f portable. hasteSysDir :: FilePath hasteSysDir = hasteUserDir -ghcLibDir :: FilePath-ghcLibDir = libdir-+-- | Haste @bin@ directory. hasteBinDir :: FilePath hasteBinDir = unsafePerformIO $ getBinDir +-- | Haste JS file directory. jsDir :: FilePath jsDir = unsafePerformIO $ getDataDir #endif -- | Haste user directory. Usually ~/.haste. hasteUserDir :: FilePath-Right hasteUserDir = unsafePerformIO . shell $ withAppDirectory "haste" return+Right hasteUserDir =+ unsafePerformIO . shell . withAppDirectory "haste" $ \d -> do+ return $ d </> showBootVersion bootVersion -- | Directory where user .jsmod files are stored. jsmodSysDir :: FilePath@@ -101,28 +104,6 @@ hostWordSize = bitSize (undefined :: CIntPtr) #endif --- | Path to the GHC binary.-ghcBinary :: FilePath-ghcBinary = unsafePerformIO $ do- exes <- catMaybes `fmap` mapM findExecutable ["ghc-" ++ cProjectVersion,- "ghc"]- case exes of- (exe:_) -> return exe- _ -> error $ "No appropriate GHC executable in search path!\n"- ++ "Are you sure you have GHC " ++ cProjectVersion- ++ " installed?"---- | Path to the GHC binary.-ghcPkgBinary :: FilePath-ghcPkgBinary = unsafePerformIO $ do- exes <- catMaybes `fmap` mapM findExecutable ["ghc-pkg-" ++ cProjectVersion,- "ghc-pkg"]- case exes of- (exe:_) -> return exe- _ -> error $ "No appropriate ghc-pkg executable in search path!\n"- ++ "Are you sure you have GHC " ++ cProjectVersion- ++ " installed?"- -- | The main Haste compiler binary. hasteBinary :: FilePath hasteBinary = hasteBinDir </> "hastec"@@ -146,3 +127,26 @@ -- | JAR for Closure compiler. closureCompiler :: FilePath closureCompiler = hasteBinDir </> "compiler.jar"++-- | File indicating whether Haste is booted or not, and for which Haste+GHC+-- version combo.+bootFile :: FilePath+bootFile = hasteSysDir </> "booted"++-- | Returns which parts of Haste need rebooting. A change in the boot file+-- format triggers a full reboot.+needsReboot :: Bool+needsReboot = unsafePerformIO $ do+ exists <- shell $ isFile bootFile+ case exists of+ Right True -> do+ fh <- openFile bootFile ReadMode+ bootedVerString <- hGetLine fh+ hClose fh+ case parseBootVersion bootedVerString of+ Just (BootVer hasteVer ghcVer) ->+ return $ hasteVer /= hasteVersion || ghcVer /= ghcVersion+ _ ->+ return True+ _ -> do+ return True
+ src/Haste/GHCPaths.hs view
@@ -0,0 +1,35 @@+-- | Paths to GHC binaries and directories.+module Haste.GHCPaths where+import Control.Shell+import System.IO.Unsafe+import System.Directory (findExecutable)+import Config (cProjectVersion)+import Data.Maybe (catMaybes)++-- | Path to the GHC binary.+ghcBinary :: FilePath+ghcBinary = unsafePerformIO $ do+ exes <- catMaybes `fmap` mapM findExecutable ["ghc-" ++ cProjectVersion,+ "ghc"]+ case exes of+ (exe:_) -> return exe+ _ -> error $ "No appropriate GHC executable in search path!\n"+ ++ "Are you sure you have GHC " ++ cProjectVersion+ ++ " installed?"++-- | Path to the GHC binary.+ghcPkgBinary :: FilePath+ghcPkgBinary = unsafePerformIO $ do+ exes <- catMaybes `fmap` mapM findExecutable ["ghc-pkg-" ++ cProjectVersion,+ "ghc-pkg"]+ case exes of+ (exe:_) -> return exe+ _ -> error $ "No appropriate ghc-pkg executable in search path!\n"+ ++ "Are you sure you have GHC " ++ cProjectVersion+ ++ " installed?"++-- | GHC library directory.+ghcLibDir :: FilePath+ghcLibDir = unsafePerformIO $ do+ Right out <- shell $ run ghcBinary ["--print-libdir"] ""+ return $ init out
src/Haste/PrimOps.hs view
@@ -150,7 +150,7 @@ -- Array ops NewArrayOp -> callF "newArr"- SameMutableArrayOp -> fmap (thunk . ret) $ bOp Eq+ SameMutableArrayOp -> fmap (thunk True . ret) $ bOp Eq ReadArrayOp -> Right $ index arr ix WriteArrayOp -> Right $ assignEx (index arr ix) rhs where (_arr:_ix:rhs:_) = xs@@ -164,7 +164,7 @@ -- Byte Array ops NewByteArrayOp_Char -> callF "newByteArr" NewPinnedByteArrayOp_Char-> callF "newByteArr"- SameMutableByteArrayOp -> fmap (thunk . ret) $ bOp Eq+ SameMutableByteArrayOp -> fmap (thunk True . ret) $ bOp Eq IndexByteArrayOp_Char -> readArr xs "i8" IndexByteArrayOp_Int -> readArr xs "i32" IndexByteArrayOp_Int8 -> readArr xs "i8"@@ -289,6 +289,12 @@ MakeStablePtrOp -> Right $ head xs EqStablePtrOp -> bOp Eq DeRefStablePtrOp -> Right $ head xs++ -- Weak pointers - no concern of GC in JS+ MkWeakOp -> callF "mkWeak"+ MkWeakNoFinalizerOp -> callF "mkWeak"+ DeRefWeakOp -> callF "derefWeak"+ FinalizeWeakOp -> callF "finalizeWeak" -- Exception masking -- There's only one thread anyway, so async exceptions can't happen.
src/Haste/Version.hs view
@@ -1,45 +1,59 @@ -- | Contains version information for Haste.-module Haste.Version (hasteVersion, ghcVersion, bootVersion, needsReboot,- BootVer (..), bootFile) where+module Haste.Version (+ BootVer (..),+ hasteVersion, intVersion, ghcVersion, bootVersion,+ showBootVersion, parseBootVersion+ ) where import System.IO.Unsafe-import Control.Shell ((</>), shell, isFile, run)-import System.IO+import Control.Shell (shell, run) import Data.Version import Config (cProjectVersion)-import Haste.Environment (hasteSysDir, ghcBinary)+import Haste.GHCPaths (ghcBinary)+import Text.ParserCombinators.ReadP+import Data.Maybe (listToMaybe) +-- | Current Haste version. hasteVersion :: Version-hasteVersion = Version [0, 4, 3] []+hasteVersion = Version [0, 4, 4] [] -ghcVersion :: String-ghcVersion = unsafePerformIO $ do- res <- shell $ run ghcBinary ["--numeric-version"] ""- case res of- Right ver -> return $ init ver -- remove trailing newline- _ -> return cProjectVersion+-- | Current Haste version as an Int. The format of this version number is+-- MAJOR*10 000 + MINOR*100 + MICRO.+-- Version 1.2.3 would thus be represented as 10203.+intVersion :: Int+intVersion = foldl (\a x -> a*100+x) 0 ver+ where Version ver _ = hasteVersion +-- | The version of GHC used to build this binary.+ghcVersion :: Version+ghcVersion =+ fst $ head $ filter (\(_,s) -> null s) parses+ where+ parses = readP_to_S parseVersion . unsafePerformIO $ do+ res <- shell $ run ghcBinary ["--numeric-version"] ""+ case res of+ Right ver -> return $ init ver -- remove trailing newline+ _ -> return cProjectVersion++-- | Haste + GHC version combo. bootVersion :: BootVer bootVersion = BootVer hasteVersion ghcVersion -bootFile :: FilePath-bootFile = hasteSysDir </> "booted"+data BootVer = BootVer {+ bootHasteVersion :: !Version,+ bootGhcVersion :: !Version+ } deriving (Show, Read) -data BootVer = BootVer Version String deriving (Read, Show)+showBootVersion :: BootVer -> String+showBootVersion (BootVer ver ghcver) =+ "haste-" ++ showVersion ver ++ "_ghc-" ++ showVersion ghcver --- | Returns which parts of Haste need rebooting. A change in the boot file--- format triggers a full reboot.-needsReboot :: Bool-needsReboot = unsafePerformIO $ do- exists <- shell $ isFile bootFile- case exists of- Right True -> do- fh <- openFile bootFile ReadMode- bootedVerString <- hGetLine fh- hClose fh- case reads bootedVerString of- [(BootVer hasteVer ghcVer, _)] ->- return $ hasteVer /= hasteVersion || ghcVer /= ghcVersion- _ ->- return True- _ -> do- return True+parseBootVersion :: String -> Maybe BootVer+parseBootVersion =+ fmap fst . listToMaybe . filter (\(_,s) -> null s) . parse+ where+ parse = readP_to_S $ do+ _ <- string "haste-"+ hastever <- parseVersion+ _ <- string "_ghc-"+ ghcver <- parseVersion+ return $ BootVer hastever ghcver
src/Main.hs view
@@ -42,7 +42,7 @@ preArgs :: [String] -> IO Bool preArgs args | "--numeric-version" `elem` args =- putStrLn ghcVersion >> return False+ putStrLn (showVersion ghcVersion) >> return False | "--info" `elem` args = printInfo >> return False | "--print-libdir" `elem` args =@@ -133,7 +133,8 @@ runGhc (Just ghcLibDir) $ do -- Handle dynamic GHC flags. Make sure __HASTE__ is #defined.- let args = "-D__HASTE__" : map unLoc ghcargs'+ let hastever = "-D__HASTE__=" ++ show intVersion+ args = hastever : map unLoc ghcargs' justDie = const $ liftIO exitFailure dynflags <- getSessionDynFlags defaultCleanupHandler dynflags $ handleSourceError justDie $ do
src/haste-boot.hs view
@@ -40,11 +40,12 @@ _ -> fail $ "Failed to download " ++ f ++ ": " ++ rspReason rsp data Cfg = Cfg {- getLibs :: Bool,- getClosure :: Bool,- useLocalLibs :: Bool,- tracePrimops :: Bool,- forceBoot :: Bool+ getLibs :: Bool,+ getClosure :: Bool,+ useLocalLibs :: Bool,+ tracePrimops :: Bool,+ forceBoot :: Bool,+ populateSetupExeCache :: Bool } defCfg :: Cfg@@ -53,11 +54,24 @@ getClosure = True, useLocalLibs = False, tracePrimops = False,- forceBoot = False+ forceBoot = False,+ populateSetupExeCache = True } +devBoot :: Cfg -> Cfg+devBoot cfg = cfg {+ useLocalLibs = True,+ forceBoot = True,+ getClosure = False,+ populateSetupExeCache = False+ }+ specs :: [OptDescr (Cfg -> Cfg)] specs = [+ Option "" ["dev"]+ (NoArg devBoot) $+ "Boot Haste for development. Implies --force " +++ "--local --no-closure --no-populate-setup-exe-cache", Option "" ["force"] (NoArg $ \cfg -> cfg {forceBoot = True}) $ "Re-boot Haste even if already properly booted.",@@ -78,6 +92,11 @@ (NoArg $ \cfg -> cfg {getLibs = False}) $ "Don't install any libraries. This is probably not " ++ "what you want.",+ Option "" ["no-populate-setup-exe-cache"]+ (NoArg $ \cfg -> cfg {populateSetupExeCache = False}) $+ "Don't populate Cabal's setup-exe-cache. Speeds up boot, " +++ "but vill fail spectacularly unless your setup-exe-cache " +++ "is already populated.", Option "" ["trace-primops"] (NoArg $ \cfg -> cfg {tracePrimops = True}) $ "Build standard libs for tracing of primitive " ++@@ -109,6 +128,10 @@ removeBootFile <- isFile bootFile when removeBootFile $ rm bootFile when (getLibs cfg) $ do+ when (populateSetupExeCache cfg) $ do+ void $ run "cabal" ["update"] ""+ void $ run "cabal" ["install", "-j", "populate-setup-exe-cache"] ""+ void $ run "ghc-pkg" ["unregister", "populate-setup-exe-cache"] "" when (not $ useLocalLibs cfg) $ do fetchLibs tmpdir mapM_ clearDir [hasteInstUserDir, jsmodUserDir, pkgUserDir,@@ -124,7 +147,7 @@ "monads-tf", "old-locale", "transformers"] when (getClosure cfg) $ do installClosure- file bootFile (show bootVersion)+ file bootFile (showBootVersion bootVersion) clearDir :: FilePath -> Shell () clearDir dir = do