haste-compiler (empty) → 0.2
raw patch · 41 files changed
+5516/−0 lines, 41 filesdep +HTTPdep +arraydep +basesetup-changed
Dependencies added: HTTP, array, base, binary, bytestring, bzlib, containers, data-default, directory, filepath, ghc, ghc-paths, ghc-prim, mtl, network, process, random, system-fileio, tar, temporary, time, transformers, zip-archive
Files
- LICENSE +30/−0
- Setup.hs +3/−0
- haste-compiler.cabal +149/−0
- lib/Integer.js +506/−0
- lib/MVar.js +55/−0
- lib/StableName.js +21/−0
- lib/array.js +36/−0
- lib/md5.js +157/−0
- lib/pointers.js +46/−0
- lib/rts.js +284/−0
- lib/stdlib.js +288/−0
- src/ArgSpecs.hs +121/−0
- src/Args.hs +53/−0
- src/Control/Shell.hs +294/−0
- src/Data/JSTarget.hs +17/−0
- src/Data/JSTarget/AST.hs +194/−0
- src/Data/JSTarget/Binary.hs +148/−0
- src/Data/JSTarget/Constructors.hs +148/−0
- src/Data/JSTarget/Op.hs +68/−0
- src/Data/JSTarget/Optimize.hs +286/−0
- src/Data/JSTarget/PP.hs +196/−0
- src/Data/JSTarget/Print.hs +204/−0
- src/Data/JSTarget/Traversal.hs +286/−0
- src/Haste.hs +8/−0
- src/Haste/Builtins.hs +43/−0
- src/Haste/CodeGen.hs +477/−0
- src/Haste/Config.hs +102/−0
- src/Haste/Environment.hs +76/−0
- src/Haste/Errors.hs +22/−0
- src/Haste/Linker.hs +110/−0
- src/Haste/Module.hs +54/−0
- src/Haste/Monad.hs +108/−0
- src/Haste/PrimOps.hs +320/−0
- src/Haste/Util.hs +8/−0
- src/Haste/Version.hs +42/−0
- src/Main.hs +241/−0
- src/haste-boot.hs +160/−0
- src/haste-copy-pkg.hs +56/−0
- src/haste-inst.hs +36/−0
- src/haste-install-his.hs +44/−0
- src/haste-pkg.hs +19/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Ekblad 2012-2013++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Milan Straka nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ haste-compiler.cabal view
@@ -0,0 +1,149 @@+Name: haste-compiler+Version: 0.2+License: BSD3+License-File: LICENSE+Synopsis: Haskell To ECMAScript compiler+Description: This package provides a featureful compiler from Haskell to+ Javascript. It generates small, fast code, makes use of+ standard Haskell libraries, integrates with Cabal, supports+ most GHC extensions and works on Windows, Linux and OSX.+ Bug reports are highly appreciated.+Category: Javascript, Compiler, Web+Cabal-Version: >= 1.10+Build-Type: Simple+Author: Anton Ekblad <anton@ekblad.cc>+Maintainer: anton@ekblad.cc+Homepage: http://github.com/valderman/haste-compiler+Bug-reports: http://github.com/valderman/haste-compiler/issues+Stability: Experimental++Data-Dir:+ lib++Data-Files:+ rts.js+ stdlib.js+ MVar.js+ StableName.js+ Integer.js+ md5.js+ array.js+ pointers.js++Executable haste-boot+ Main-Is: haste-boot.hs+ Other-Modules:+ Haste.Version+ Haste.Environment+ Control.Shell+ Hs-Source-Dirs: src+ GHC-Options: -Wall -O2+ Build-Depends:+ ghc,+ base < 5,+ directory,+ process,+ bytestring,+ tar,+ bzlib,+ zip-archive,+ filepath,+ temporary,+ time,+ transformers,+ network,+ HTTP+ Default-Language: Haskell98++Executable hastec+ Hs-Source-Dirs: src+ GHC-Options: -Wall -O2+ Build-Depends:+ base < 5,+ ghc-prim,+ ghc >= 7.6,+ mtl,+ binary,+ containers,+ data-default,+ bytestring >= 0.10.0.0,+ filepath,+ directory,+ array,+ ghc-paths,+ process,+ random,+ system-fileio+ Main-Is:+ Main.hs+ Other-Modules:+ Args+ ArgSpecs+ Haste+ Haste.Util+ Haste.Version+ Haste.Environment+ Haste.Config+ Haste.Monad+ Haste.PrimOps+ Haste.Module+ Haste.Linker+ Haste.Builtins+ Haste.Errors+ Haste.CodeGen+ Data.JSTarget+ Data.JSTarget.AST+ Data.JSTarget.Binary+ Data.JSTarget.Constructors+ Data.JSTarget.Op+ Data.JSTarget.Optimize+ Data.JSTarget.PP+ Data.JSTarget.Print+ Data.JSTarget.Traversal+ default-language: Haskell98++Executable haste-inst+ Main-Is: haste-inst.hs+ Hs-Source-Dirs: src+ Build-Depends:+ base < 5,+ filepath,+ process,+ directory+ default-language: Haskell98++Executable haste-pkg+ Main-Is: haste-pkg.hs+ Hs-Source-Dirs: src+ Build-Depends:+ base < 5,+ process,+ filepath,+ directory+ default-language: Haskell98++Executable haste-install-his+ Main-Is: haste-install-his.hs+ Hs-Source-Dirs: src+ Build-Depends:+ base < 5,+ filepath,+ directory,+ process+ default-language: Haskell98++Executable haste-copy-pkg+ Main-Is: haste-copy-pkg.hs+ Other-Modules:+ Haste.Environment+ Control.Shell+ Hs-Source-Dirs: src+ Build-Depends:+ base < 5,+ filepath,+ directory,+ process,+ temporary,+ time,+ transformers+ default-language: Haskell98
+ lib/Integer.js view
@@ -0,0 +1,506 @@+var Integer = function(bits, sign) {+ this.bits_ = [];+ this.sign_ = sign;++ var top = true;+ for (var i = bits.length - 1; i >= 0; i--) {+ var val = bits[i] | 0;+ if (!top || val != sign) {+ this.bits_[i] = val;+ top = false;+ }+ }+};++Integer.IntCache_ = {};++var I_fromInt = function(value) {+ if (-128 <= value && value < 128) {+ var cachedObj = Integer.IntCache_[value];+ if (cachedObj) {+ return cachedObj;+ }+ }++ var obj = new Integer([value | 0], value < 0 ? -1 : 0);+ if (-128 <= value && value < 128) {+ Integer.IntCache_[value] = obj;+ }+ return obj;+};++var I_fromNumber = function(value) {+ if (isNaN(value) || !isFinite(value)) {+ return Integer.ZERO;+ } else if (value < 0) {+ return I_negate(I_fromNumber(-value));+ } else {+ var bits = [];+ var pow = 1;+ for (var i = 0; value >= pow; i++) {+ bits[i] = (value / pow) | 0;+ pow *= Integer.TWO_PWR_32_DBL_;+ }+ return new Integer(bits, 0);+ }+};++Integer.fromBits = function(bits) {+ var high = bits[bits.length - 1];+ return new Integer(bits, high & (1 << 31) ? -1 : 0);+};++I_fromString = function(str, opt_radix) {+ if (str.length == 0) {+ throw Error('number format error: empty string');+ }++ var radix = opt_radix || 10;+ if (radix < 2 || 36 < radix) {+ throw Error('radix out of range: ' + radix);+ }++ if (str.charAt(0) == '-') {+ return I_negate(I_fromString(str.substring(1), radix));+ } else if (str.indexOf('-') >= 0) {+ throw Error('number format error: interior "-" character');+ }++ var radixToPower = I_fromNumber(Math.pow(radix, 8));++ var result = Integer.ZERO;+ for (var i = 0; i < str.length; i += 8) {+ var size = Math.min(8, str.length - i);+ var value = parseInt(str.substring(i, i + size), radix);+ if (size < 8) {+ var power = I_fromNumber(Math.pow(radix, size));+ result = I_add(I_mul(result, power), I_fromNumber(value));+ } else {+ result = I_mul(result, radixToPower);+ result = I_add(add, I_fromNumber(value));+ }+ }+ return result;+};+++Integer.TWO_PWR_32_DBL_ = (1 << 16) * (1 << 16);+Integer.ZERO = I_fromInt(0);+Integer.ONE = I_fromInt(1);+Integer.TWO_PWR_24_ = I_fromInt(1 << 24);++var I_toInt = function(self) {+ return self.bits_.length > 0 ? self.bits_[0] : self.sign_;+};++var I_toWord = function(self) {+ return I_toInt(self) >>> 0;+};++var I_toNumber = function(self) {+ if (isNegative(self)) {+ return -I_toNumber(I_negate(self));+ } else {+ var val = 0;+ var pow = 1;+ for (var i = 0; i < self.bits_.length; i++) {+ val += getBitsUnsigned(self, i) * pow;+ pow *= Integer.TWO_PWR_32_DBL_;+ }+ return val;+ }+};++var getBits = function(self, index) {+ if (index < 0) {+ return 0;+ } else if (index < self.bits_.length) {+ return self.bits_[index];+ } else {+ return self.sign_;+ }+};++var getBitsUnsigned = function(self, index) {+ var val = getBits(self, index);+ return val >= 0 ? val : Integer.TWO_PWR_32_DBL_ + val;+};++var getSign = function(self) {+ return self.sign_;+};++var isZero = function(self) {+ if (self.sign_ != 0) {+ return false;+ }+ for (var i = 0; i < self.bits_.length; i++) {+ if (self.bits_[i] != 0) {+ return false;+ }+ }+ return true;+};++var isNegative = function(self) {+ return self.sign_ == -1;+};++var isOdd = function(self) {+ return (self.bits_.length == 0) && (self.sign_ == -1) ||+ (self.bits_.length > 0) && ((self.bits_[0] & 1) != 0);+};++var I_equals = function(self, other) {+ if (self.sign_ != other.sign_) {+ return false;+ }+ var len = Math.max(self.bits_.length, other.bits_.length);+ for (var i = 0; i < len; i++) {+ if (getBits(self, i) != getBits(other, i)) {+ return false;+ }+ }+ return true;+};++var I_notEquals = function(self, other) {+ return !I_equals(self, other);+};++var greaterThan = function(self, other) {+ return I_compare(self, other) > 0;+};++var greaterThanOrEqual = function(self, other) {+ return I_compare(self, other) >= 0;+};++var lessThan = function(self, other) {+ return I_compare(self, other) < 0;+};++var lessThanOrEqual = function(self, other) {+ return I_compare(self, other) <= 0;+};++var I_compare = function(self, other) {+ var diff = I_sub(self, other);+ if (isNegative(diff)) {+ return -1;+ } else if (isZero(diff)) {+ return 0;+ } else {+ return +1;+ }+};++var I_compareInt = function(self, other) {+ return I_compare(self, I_fromInt(other));+}++var shorten = function(self, numBits) {+ var arr_index = (numBits - 1) >> 5;+ var bit_index = (numBits - 1) % 32;+ var bits = [];+ for (var i = 0; i < arr_index; i++) {+ bits[i] = getBits(self, i);+ }+ var sigBits = bit_index == 31 ? 0xFFFFFFFF : (1 << (bit_index + 1)) - 1;+ var val = getBits(self, arr_index) & sigBits;+ if (val & (1 << bit_index)) {+ val |= 0xFFFFFFFF - sigBits;+ bits[arr_index] = val;+ return new Integer(bits, -1);+ } else {+ bits[arr_index] = val;+ return new Integer(bits, 0);+ }+};++var I_negate = function(self) {+ return I_add(not(self), Integer.ONE);+};++var I_add = function(self, other) {+ var len = Math.max(self.bits_.length, other.bits_.length);+ var arr = [];+ var carry = 0;++ for (var i = 0; i <= len; i++) {+ var a1 = getBits(self, i) >>> 16;+ var a0 = getBits(self, i) & 0xFFFF;++ var b1 = getBits(other, i) >>> 16;+ var b0 = getBits(other, i) & 0xFFFF;++ var c0 = carry + a0 + b0;+ var c1 = (c0 >>> 16) + a1 + b1;+ carry = c1 >>> 16;+ c0 &= 0xFFFF;+ c1 &= 0xFFFF;+ arr[i] = (c1 << 16) | c0;+ }+ return Integer.fromBits(arr);+};++var I_sub = function(self, other) {+ return I_add(self, I_negate(other));+};++var I_mul = function(self, other) {+ if (isZero(self)) {+ return Integer.ZERO;+ } else if (isZero(other)) {+ return Integer.ZERO;+ }++ if (isNegative(self)) {+ if (isNegative(other)) {+ return I_mul(I_negate(self), I_negate(other));+ } else {+ return I_negate(I_mul(I_negate(self), other));+ }+ } else if (isNegative(other)) {+ return I_negate(I_mul(self, I_negate(other)));+ }++ if (lessThan(self, Integer.TWO_PWR_24_) &&+ lessThan(other, Integer.TWO_PWR_24_)) {+ return I_fromNumber(I_toNumber(self) * I_toNumber(other));+ }++ var len = self.bits_.length + other.bits_.length;+ var arr = [];+ for (var i = 0; i < 2 * len; i++) {+ arr[i] = 0;+ }+ for (var i = 0; i < self.bits_.length; i++) {+ for (var j = 0; j < other.bits_.length; j++) {+ var a1 = getBits(self, i) >>> 16;+ var a0 = getBits(self, i) & 0xFFFF;++ var b1 = getBits(other, j) >>> 16;+ var b0 = getBits(other, j) & 0xFFFF;++ arr[2 * i + 2 * j] += a0 * b0;+ Integer.carry16_(arr, 2 * i + 2 * j);+ arr[2 * i + 2 * j + 1] += a1 * b0;+ Integer.carry16_(arr, 2 * i + 2 * j + 1);+ arr[2 * i + 2 * j + 1] += a0 * b1;+ Integer.carry16_(arr, 2 * i + 2 * j + 1);+ arr[2 * i + 2 * j + 2] += a1 * b1;+ Integer.carry16_(arr, 2 * i + 2 * j + 2);+ }+ }++ for (var i = 0; i < len; i++) {+ arr[i] = (arr[2 * i + 1] << 16) | arr[2 * i];+ }+ for (var i = len; i < 2 * len; i++) {+ arr[i] = 0;+ }+ return new Integer(arr, 0);+};++Integer.carry16_ = function(bits, index) {+ while ((bits[index] & 0xFFFF) != bits[index]) {+ bits[index + 1] += bits[index] >>> 16;+ bits[index] &= 0xFFFF;+ }+};++var I_mod = function(self, other) {+ return I_rem(I_add(other, I_rem(self, other)), other);+}++var I_div = function(self, other) {+ if(greaterThan(self, Integer.ZERO) != greaterThan(other, Integer.ZERO)) {+ if(I_rem(self, other) != Integer.ZERO) {+ return I_sub(I_quot(self, other), Integer.ONE);+ }+ }+ return I_quot(self, other);+}++var I_quotRem = function(self, other) {+ return [1, I_quot(self, other), I_rem(self, other)];+}++var I_divMod = function(self, other) {+ return [1, I_div(self, other), I_mod(self, other)];+}++var I_quot = function(self, other) {+ if (isZero(other)) {+ throw Error('division by zero');+ } else if (isZero(self)) {+ return Integer.ZERO;+ }++ if (isNegative(self)) {+ if (isNegative(other)) {+ return I_quot(I_negate(self), I_negate(other));+ } else {+ return I_negate(I_quot(I_negate(self), other));+ }+ } else if (isNegative(other)) {+ return I_negate(I_quot(self, I_negate(other)));+ }++ var res = Integer.ZERO;+ var rem = self;+ while (greaterThanOrEqual(rem, other)) {+ var approx = Math.max(1, Math.floor(I_toNumber(rem) / I_toNumber(other)));+ var log2 = Math.ceil(Math.log(approx) / Math.LN2);+ var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48);+ var approxRes = I_fromNumber(approx);+ var approxRem = I_mul(approxRes, other);+ while (isNegative(approxRem) || greaterThan(approxRem, rem)) {+ approx -= delta;+ approxRes = I_fromNumber(approx);+ approxRem = I_mul(approxRes, other);+ }++ if (isZero(approxRes)) {+ approxRes = Integer.ONE;+ }++ res = I_add(res, approxRes);+ rem = I_sub(rem, approxRem);+ }+ return res;+};++var I_rem = function(self, other) {+ return I_sub(self, I_mul(I_quot(self, other), other));+};++var not = function(self) {+ var len = self.bits_.length;+ var arr = [];+ for (var i = 0; i < len; i++) {+ arr[i] = ~self.bits_[i];+ }+ return new Integer(arr, ~self.sign_);+};++var I_and = function(self, other) {+ var len = Math.max(self.bits_.length, other.bits_.length);+ var arr = [];+ for (var i = 0; i < len; i++) {+ arr[i] = getBits(self, i) & getBits(other, i);+ }+ return new Integer(arr, self.sign_ & other.sign_);+};++var I_or = function(self, other) {+ var len = Math.max(self.bits_.length, other.bits_.length);+ var arr = [];+ for (var i = 0; i < len; i++) {+ arr[i] = getBits(self, i) | getBits(other, i);+ }+ return new Integer(arr, self.sign_ | other.sign_);+};++var I_xor = function(self, other) {+ var len = Math.max(self.bits_.length, other.bits_.length);+ var arr = [];+ for (var i = 0; i < len; i++) {+ arr[i] = getBits(self, i) ^ getBits(other, i);+ }+ return new Integer(arr, self.sign_ ^ other.sign_);+};++var I_shiftLeft = function(self, numBits) {+ var arr_delta = numBits >> 5;+ var bit_delta = numBits % 32;+ var len = self.bits_.length + arr_delta + (bit_delta > 0 ? 1 : 0);+ var arr = [];+ for (var i = 0; i < len; i++) {+ if (bit_delta > 0) {+ arr[i] = (getBits(self, i - arr_delta) << bit_delta) |+ (getBits(self, i - arr_delta - 1) >>> (32 - bit_delta));+ } else {+ arr[i] = getBits(self, i - arr_delta);+ }+ }+ return new Integer(arr, self.sign_);+};++var I_shiftRight = function(self, numBits) {+ var arr_delta = numBits >> 5;+ var bit_delta = numBits % 32;+ var len = self.bits_.length - arr_delta;+ var arr = [];+ for (var i = 0; i < len; i++) {+ if (bit_delta > 0) {+ arr[i] = (getBits(self, i + arr_delta) >>> bit_delta) |+ (getBits(self, i + arr_delta + 1) << (32 - bit_delta));+ } else {+ arr[i] = getBits(self, i + arr_delta);+ }+ }+ return new Integer(arr, self.sign_);+};++var I_signum = function(self) {+ var cmp = I_compare(self, Integer.ZERO);+ if(cmp > 0) {+ return Integer.ONE+ }+ if(cmp < 0) {+ return I_sub(Integer.ZERO, Integer.ONE);+ }+ return Integer.ZERO;+};++var I_abs = function(self) {+ if(I_compare(self, Integer.ZERO) < 0) {+ return I_sub(Integer.ZERO, self);+ }+ return self;+};++var I_decodeDouble = function(x) {+ var dec = decodeDouble(x);+ var mantissa = Integer.fromBits([dec[3], dec[2]]);+ if(dec[1] < 0) {+ mantissa = I_negate(mantissa);+ }+ return [1, dec[4], mantissa];+}++var I_toString = function(self) {+ var radix = 10;++ if (isZero(self)) {+ return '0';+ } else if (isNegative(self)) {+ return '-' + I_toString(I_negate(self));+ }++ var radixToPower = I_fromNumber(Math.pow(radix, 6));++ var rem = self;+ var result = '';+ while (true) {+ var remDiv = I_div(rem, radixToPower);+ var intval = I_toInt(I_sub(rem, I_mul(remDiv, radixToPower)));+ var digits = intval.toString();++ rem = remDiv;+ if (isZero(rem)) {+ return digits + result;+ } else {+ while (digits.length < 6) {+ digits = '0' + digits;+ }+ result = '' + digits + result;+ }+ }+};++var I_fromRat = function(a, b) {+ return I_toNumber(a) / I_toNumber(b);+}
+ lib/MVar.js view
@@ -0,0 +1,55 @@+// MVar implementation.+// Since Haste isn't concurrent, takeMVar and putMVar don't block on empty+// and full MVars respectively, but terminate the program since they would+// otherwise be blocking forever.++function newMVar() {+ return ({empty: true});+}++function tryTakeMVar(mv) {+ if(mv.empty) {+ return [1, 0, undefined];+ } else {+ mv.empty = true;+ mv.x = null;+ return [1, 1, mv.x];+ }+}++function takeMVar(mv) {+ if(mv.empty) {+ // TODO: real BlockedOnDeadMVar exception, perhaps?+ err("Attempted to take empty MVar!");+ }+ mv.empty = true;+ mv.x = null;+ return mv.x;+}++function putMVar(mv, val) {+ if(!mv.empty) {+ // TODO: real BlockedOnDeadMVar exception, perhaps?+ err("Attempted to put full MVar!");+ }+ mv.empty = false;+ mv.x = val;+}++function tryPutMVar(mv, val) {+ if(!mv.empty) {+ return 0;+ } else {+ mv.empty = false;+ mv.x = val;+ return 1;+ }+}++function sameMVar(a, b) {+ return (a == b);+}++function isEmptyMVar(mv) {+ return mv.empty ? 1 : 0;+}
+ lib/StableName.js view
@@ -0,0 +1,21 @@+// Implementation of stable names.+// Unlike native GHC, the garbage collector isn't going to move data around+// in a way that we can detect, so each object could serve as its own stable+// name if it weren't for the fact we can't turn a JS reference into an+// integer.+// So instead, each object has a unique integer attached to it, which serves+// as its stable name.++var __next_stable_name = 1;++function makeStableName(x) {+ if(!x.stableName) {+ x.stableName = __next_stable_name;+ __next_stable_name += 1;+ }+ return x.stableName;+}++function eqStableName(x, y) {+ return (x == y) ? 1 : 0;+}
+ lib/array.js view
@@ -0,0 +1,36 @@+// Functions for dealing with arrays.++function newArr(n, x) {+ var arr = [];+ for(; n >= 0; --n) {+ arr.push(x);+ }+ return arr;+}++// Create all views at once; perhaps it's wasteful, but it's better than having+// to check for the right view at each read or write.+function newByteArr(n) {+ // Pad the thing to multiples of 8.+ var padding = 8 - n % 8;+ if(padding < 8) {+ n += padding;+ }+ var arr = {};+ var buffer = new ArrayBuffer(n);+ var views = {};+ views['i8'] = new Int8Array(buffer);+ views['i16'] = new Int16Array(buffer);+ views['i32'] = new Int32Array(buffer);+ views['w8'] = new Uint8Array(buffer);+ views['w16'] = new Uint16Array(buffer);+ views['w32'] = new Uint32Array(buffer);+ views['f32'] = new Float32Array(buffer);+ views['f64'] = new Float64Array(buffer);+ arr['b'] = buffer;+ arr['v'] = views;+ // ByteArray and Addr are the same thing, so keep an offset if we get+ // casted.+ arr['off'] = 0;+ return arr;+}
+ lib/md5.js view
@@ -0,0 +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];++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 = 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);++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);+}++function ff(a, b, c, d, 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);+}++function hh(a, b, c, d, 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);+}++function md51(s) {+txt = '';+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;+}++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 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;+}++function hex(x) {+for (var i=0; i<x.length; i++)+x[i] = rhex(x[i]);+return x.join('');+}++function md5(s) {+return hex(md51(s));+}++function add32(a, b) {+return (a + b) & 0xFFFFFFFF;+}
+ lib/pointers.js view
@@ -0,0 +1,46 @@+// An attempt at emulating pointers enough for ByteString and Text to be+// usable without patching the hell out of them.+// The general idea is that Addr# is a byte array with an associated offset.++function plusAddr(addr, off) {+ var newaddr = {};+ newaddr['off'] = addr['off'] + off;+ newaddr['b'] = addr['b'];+ newaddr['v'] = addr['v'];+ return newaddr;+}++function writeOffAddr(type, elemsize, addr, off, x) {+ addr['v'][type][addr.off/elemsize + off] = x;+}++function readOffAddr(type, elemsize, addr, off) {+ return addr['v'][type][addr.off/elemsize + off];+}++// Two addresses are equal if they point to the same buffer and have the same+// offset. For other comparisons, just use the offsets - nobody in their right+// mind would check if one pointer is less than another, completely unrelated,+// pointer and then act on that information anyway.+function addrEq(a, b) {+ if(a == b) {+ return true;+ }+ return a && b && a['b'] == b['b'] && a['off'] == b['off'];+}++function addrLT(a, b) {+ if(a) {+ return b && a['off'] < b['off'];+ } else {+ return (b != 0); + }+}++function addrGT(a, b) {+ if(b) {+ return a && a['off'] > b['off'];+ } else {+ return (a != 0);+ }+}
+ lib/rts.js view
@@ -0,0 +1,284 @@+/* 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'.+*/++function T(f) {+ return new Thunk(f);+}++function Thunk(f) {+ this.f = f;+}++/* 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-+ saturated, the function is fully applied, and the result (assumed to be a+ function) is then applied to the remaining arguments.+*/+function A(f, args) {+ f = f instanceof Thunk ? E(f) : f;+ // Closure does some funny stuff with functions that occasionally+ // results in non-functions getting applied, so we have to deal with+ // it.+ if(!f.apply) {+ return f;+ }++ var arity = f.arity ? f.arity : f.length;+ if(args.length === arity) {+ return f.apply(null, args);+ }+ if(args.length > arity) {+ var first = args.splice(0, arity);+ return A(f.apply(null, first), args);+ } else {+ var g = function() {+ var as = args.concat(Array.prototype.slice.call(arguments));+ return A(f, as);+ };+ g.arity = arity - args.length;+ return g;+ }+}++/* Eval+ Evaluate the given thunk t into head normal form.+ If the "thunk" we get isn't actually a thunk, just return it.+*/+function E(t) {+ if(t instanceof Thunk) {+ if(t.f) {+ t.x = t.f();+ t.f = 0;+ }+ return t.x;+ }+ return t;+}++/* Throw an error.+ We need to be able to use throw as an exception so we wrap it in a function.+*/+function die(err) {+ throw err;+}++function quot(a, b) {+ return (a-a%b)/b;+}++function quotRemI(a, b) {+ return [1, (a-a%b)/b, a%b];+}++// 32 bit integer multiplication, with correct overflow behavior+// note that |0 or >>>0 needs to be applied to the result, for int and word+// respectively.+function imul(a, b) {+ // ignore high a * high a as the result will always be truncated+ var lows = (a & 0xffff) * (b & 0xffff); // low a * low b+ var aB = (a & 0xffff) * (b & 0xffff0000); // low a * high b+ var bA = (a & 0xffff0000) * (b & 0xffff); // low b * high a+ return lows + aB + bA; // sum will not exceed 52 bits, so it's safe+}++function addC(a, b) {+ var x = a+b;+ return [1, x & 0xffffffff, x > 0x7fffffff];+}++function subC(a, b) {+ var x = a-b;+ return [1, x & 0xffffffff, x < -2147483648];+}++function sinh (arg) {+ return (Math.exp(arg) - Math.exp(-arg)) / 2;+}++function tanh (arg) {+ return (Math.exp(arg) - Math.exp(-arg)) / (Math.exp(arg) + Math.exp(-arg));+}++function cosh (arg) {+ return (Math.exp(arg) + Math.exp(-arg)) / 2;+}++// Scratch space for byte arrays.+var rts_scratchBuf = new ArrayBuffer(8);+var rts_scratchW32 = new Uint32Array(rts_scratchBuf);+var rts_scratchFloat = new Float32Array(rts_scratchBuf);+var rts_scratchDouble = new Float64Array(rts_scratchBuf);++function decodeFloat(x) {+ rts_scratchFloat[0] = x;+ var sign = x < 0 ? -1 : 1;+ var exp = ((rts_scratchW32[0] >> 23) & 0xff) - 150;+ var man = rts_scratchW32[0] & 0x7fffff;+ if(exp === 0) {+ ++exp;+ } else {+ man |= (1 << 23);+ }+ return [1, sign*man, exp];+}++function decodeDouble(x) {+ rts_scratchDouble[0] = x;+ var sign = x < 0 ? -1 : 1;+ var manHigh = rts_scratchW32[1] & 0xfffff;+ var manLow = rts_scratchW32[0];+ var exp = ((rts_scratchW32[1] >> 20) & 0x7ff) - 1075;+ if(exp === 0) {+ ++exp;+ } else {+ manHigh |= (1 << 20);+ }+ return [1, sign, manHigh, manLow, exp];+}++function err(str) {+ die(toJSStr(str)[1]);+}++/* unpackCString#+ NOTE: update constructor tags if the code generator starts munging them.+*/+function unCStr(str) {return unAppCStr(str, [1]);}++function unFoldrCStr(str, f, z) {+ var acc = z;+ for(var i = str.length-1; i >= 0; --i) {+ acc = A(f, [[1, str.charCodeAt(i)], acc]);+ }+ return acc;+}++function unAppCStr(str, chrs) {+ var i = arguments[2] ? arguments[2] : 0;+ if(i >= str.length) {+ return E(chrs);+ } else {+ return [2,[1,str.charCodeAt(i)],T(function() {+ return unAppCStr(str,chrs,i+1);+ })];+ }+}++function charCodeAt(str, i) {return str.charCodeAt(i);}++function fromJSStr(str) {+ return unCStr(E(str)[1]);+}++function toJSStr(hsstr) {+ var s = '';+ for(var str = E(hsstr); str[0] == 2; str = E(str[2])) {+ s += String.fromCharCode(E(str[1])[1]);+ }+ return [1,s];+}++// newMutVar+function nMV(val) {+ return ({x: val});+}++// readMutVar+function rMV(mv) {+ return mv.x;+}++// writeMutVar+function wMV(mv, val) {+ mv.x = val;+}++function localeEncoding() {+ var le = newByteArr(5);+ le['b']['i8'] = 'U'.charCodeAt(0);+ le['b']['i8'] = 'T'.charCodeAt(0);+ le['b']['i8'] = 'F'.charCodeAt(0);+ le['b']['i8'] = '-'.charCodeAt(0);+ le['b']['i8'] = '8'.charCodeAt(0);+ return le;+}++var isFloatNaN = isDoubleNaN = isNaN;++function isDoubleInfinite(d) {+ return (d === Infinity);+}+var isFloatInfinite = isDoubleInfinite;++function isDoubleNegativeZero(x) {+ return (x===0 && (1/x)===-Infinity);+}+var isFloatNegativeZero = isDoubleNegativeZero;++function strEq(a, b) {+ return a == b;+}++function strOrd(a, b) {+ var ord;+ if(a < b) {+ ord = [1];+ } else if(a == b) {+ ord = [2];+ } else {+ ord = [3];+ }+ return ord;+}++function jsCatch(act, handler) {+ try {+ return A(act,[0]);+ } catch(e) {+ return A(handler,[e, 0]);+ }+}++function hs_eqWord64(a, b) {+ return (a[0] == b[0] && a[1] == b[1]);+}++// Word64# representation: (Word, Word)+function hs_wordToWord64(low) {+ return [0, low];+}++function hs_mkWord64(high, low) {+ return [high, low];+}++var coercionToken = undefined;++/* Haste represents constructors internally using 1 for the first constructor,+ 2 for the second, etc.+ However, dataToTag should use 0, 1, 2, etc. Also, booleans might be unboxed.+ */+function dataToTag(x) {+ if(x instanceof Array) {+ return x[0]-1;+ } else {+ return x-1;+ }+}++function __word_encodeDouble(d, e) {+ return d * Math.pow(2,e);+}++var __word_encodeFloat = __word_encodeDouble;+var jsRound = Math.round; // Stupid GHC doesn't like periods in FFI IDs...+if(typeof _ == 'undefined') {+ var _ = undefined;+}
+ lib/stdlib.js view
@@ -0,0 +1,288 @@+function jsAlert(val) {+ if(typeof alert != 'undefined') {+ alert(val);+ } else {+ print(val);+ }+}++function jsLog(val) {+ console.log(val);+}++function jsPrompt(str) {+ var val;+ if(typeof prompt != 'undefined') {+ val = prompt(str);+ } else {+ print(str);+ val = readline();+ }+ return val == undefined ? '' : val.toString();+}++function jsEval(str) {+ var x = eval(str);+ return x == undefined ? '' : x.toString();+}++function isNull(obj) {+ return obj === null;+}++function jsRead(str) {+ return Number(str);+}++function jsShowI(val) {return val.toString();}+function jsShow(val) {+ var ret = val.toString();+ return val == Math.round(val) ? ret + '.0' : ret;+}++function jsSetCB(elem, evt, cb) {+ // Count return press in single line text box as a change event.+ if(evt == 'change' && elem.type.toLowerCase() == 'text') {+ setCB(elem, 'keyup', function(k) {+ if(k == '\n'.charCodeAt(0)) {+ A(cb,[[1,k.keyCode],0]);+ }+ });+ }++ var fun;+ switch(evt) {+ case 'click':+ case 'dblclick':+ case 'mouseup':+ case 'mousedown':+ fun = function(x) {A(cb,[[1,x.button],0]);};+ break;+ case 'keypress':+ case 'keyup':+ case 'keydown':+ fun = function(x) {A(cb,[[1,x.keyCode],0]);};+ break; + default:+ fun = function() {A(cb,[0]);};+ break;+ }+ return setCB(elem, evt, fun);+}++function setCB(elem, evt, cb) {+ if(elem.addEventListener) {+ elem.addEventListener(evt, cb, false);+ return true;+ } else if(elem.attachEvent) {+ elem.attachEvent('on'+evt, cb);+ return true;+ }+ return false;+}++function jsSetTimeout(msecs, cb) {+ window.setTimeout(function() {A(cb,[0]);}, msecs);+}++// Degenerate versions of u_iswspace, u_iswalnum and u_iswalpha.+function u_iswspace(c) {+ return c==9 || c==10 || c==13 || c==32;+}++function u_iswalnum(c) {+ return (c >= 48 && c <= 57) || u_iswalpha(c);+}++// [a-zA-ZåäöÅÄÖ]+function u_iswalpha(c) {+ return (c >= 65 && c <= 90) || (c >= 97 && c <= 122) ||+ c == 229 || c == 228 || c == 246 ||+ c == 197 || c == 196 || c == 214;+}++function jsGet(elem, prop) {+ return elem[prop].toString();+}++function jsSet(elem, prop, val) {+ elem[prop] = val;+}++function jsGetStyle(elem, prop) {+ return elem.style[prop].toString();+}++function jsSetStyle(elem, prop, val) {+ elem.style[prop] = val;+}++function jsKillChild(child, parent) {+ parent.removeChild(child);+}++function jsClearChildren(elem) {+ while(elem.hasChildNodes()){+ elem.removeChild(elem.lastChild);+ }+}++function jsFind(elem) {+ var e = document.getElementById(elem)+ if(e) {+ return [2,[1,e]];+ }+ return [1];+}++function jsCreateElem(tag) {+ return document.createElement(tag);+}++function jsGetChildBefore(elem) {+ elem = elem.previousSibling;+ while(elem) {+ if(typeof elem.tagName != 'undefined') {+ return [2,[1,elem]];+ }+ elem = elem.previousSibling;+ }+ return [1];+}++function jsGetLastChild(elem) {+ var len = elem.childNodes.length;+ for(var i = len-1; i >= 0; --i) {+ if(typeof elem.childNodes[i].tagName != 'undefined') {+ return [2,[1,elem.childNodes[i]]];+ }+ }+ return [1];+}++function jsGetChildren(elem) {+ var children = [1];+ var len = elem.childNodes.length;+ for(var i = len-1; i >= 0; --i) {+ if(typeof elem.childNodes[i].tagName != 'undefined') {+ children = [2, [1,elem.childNodes[i]], children];+ }+ }+ return children;+}++function jsSetChildren(elem, children) {+ children = E(children);+ jsClearChildren(elem, 0);+ while(children[0] === 2) {+ elem.appendChild(E(E(children[1])[1]));+ children = E(children[2]);+ }+}++function jsAppendChild(child, container) {+ container.appendChild(child);+}++function jsAddChildBefore(child, container, after) {+ container.insertBefore(child, after);+}++var jsRand = Math.random;++// Concatenate a Haskell list of JS strings+function jsCat(strs, sep) {+ var arr = [];+ strs = E(strs);+ while(strs[0] != 1) {+ strs = E(strs);+ arr.push(E(strs[1])[1]);+ strs = E(strs[2]);+ }+ return arr.join(sep);+}++// Escape all double quotes in a string+function jsUnquote(str) {+ return str.replace(/"/, '\\"');+}++// Parse a JSON message into a Haste.JSON.JSON value.+// As this pokes around inside Haskell values, it'll need to be updated if:+// * Haste.JSON.JSON changes;+// * E() starts to choke on non-thunks;+// * data constructor code generation changes; or+// * Just and Nothing change tags.+function jsParseJSON(str) {+ try {+ var js = JSON.parse(str);+ var hs = toHS(js);+ } catch(_) {+ return [1];+ }+ return [2,hs];+}++function toHS(obj) {+ switch(typeof obj) {+ case 'number':+ return [1, [1, jsRead(obj)]];+ case 'string':+ return [2, [1, obj]];+ break;+ case 'boolean':+ return [3, obj]; // Booleans are special wrt constructor tags!+ break;+ case 'object':+ if(obj instanceof Array) {+ return [4, arr2lst(obj, 0)];+ } else {+ // Object type but not array - it's a dictionary.+ // The RFC doesn't say anything about the ordering of keys, but+ // considering that lots of people rely on keys being "in order" as+ // defined by "the same way someone put them in at the other end,"+ // it's probably a good idea to put some cycles into meeting their+ // misguided expectations.+ var ks = [];+ for(var k in obj) {+ ks.unshift(k);+ }+ var xs = [1];+ for(var i in ks) {+ xs = [2, [1, [1,ks[i]], toHS(obj[ks[i]])], xs];+ }+ return [5, xs];+ }+ }+}++function arr2lst(arr, elem) {+ if(elem >= arr.length) {+ return [1];+ }+ return [2, toHS(arr[elem]), T(function() {return arr2lst(arr,elem+1);})]+}++function ajaxReq(method, url, async, postdata, cb) {+ var xhr = new XMLHttpRequest();+ xhr.open(method, url, async);+ xhr.setRequestHeader('Cache-control', 'no-cache');+ xhr.onreadystatechange = function() {+ if(xhr.readyState == 4) {+ if(xhr.status == 200) {+ A(cb,[[2,[1,xhr.responseText]],0]);+ } else {+ A(cb,[[1],0]); // Nothing+ }+ }+ }+ xhr.send(postdata);+}++function u_towlower(charCode) {+ return String.fromCharCode(charCode).toLowerCase().charCodeAt(0);+}++function u_towupper(charCode) {+ return String.fromCharCode(charCode).toUpperCase().charCodeAt(0);+}
+ src/ArgSpecs.hs view
@@ -0,0 +1,121 @@+-- | All of hastec's command line arguments.+module ArgSpecs (argSpecs) where+import Args+import Haste.Config+import Haste.Environment+import Data.JSTarget.PP (debugPPOpts)++argSpecs :: [ArgSpec Config]+argSpecs = [+ ArgSpec { optName = "debug",+ updateCfg = \cfg _ -> cfg {ppOpts = debugPPOpts},+ info = "Output indented, fairly readable code, with all " +++ "external names included in comments."},+ ArgSpec { optName = "dont-link",+ updateCfg = \cfg _ -> cfg {performLink = False},+ info = "Don't perform linking."},+ ArgSpec { optName = "libinstall",+ updateCfg = \cfg _ -> cfg {targetLibPath = jsmodDir,+ performLink = False},+ info = "Install all compiled modules into the user's jsmod "+ ++ "library\nrather than linking them together into a JS"+ ++ "blob."},+ -- The opt-all enabling -O2 thing is handled directly in main! :(+ ArgSpec { optName = "opt-all",+ updateCfg = optAllSafe,+ info = "Enable all safe optimizations. "+ ++ "Equivalent to -O2 --opt-whole-program "+ ++ "--opt-google-closure."},+ ArgSpec { optName = "opt-all-unsafe",+ updateCfg = optAllUnsafe,+ info = "Enable all safe and unsafe optimizations.\n"+ ++ "Equivalent to --opt-all --opt-unsafe-ints."},+ ArgSpec { optName = "opt-google-closure",+ updateCfg = updateClosureCfg,+ info = "Run the Google Closure compiler on the output. "+ ++ "Use --opt-google-closure=foo.jar to hint that foo.jar "+ ++ "is the Closure compiler."},+ ArgSpec { optName = "opt-sloppy-tce",+ updateCfg = useSloppyTCE,+ info = "Allow the possibility that some tail recursion may not "+ ++ "be optimized, to get\nslightly smaller code."},+ ArgSpec { optName = "opt-unsafe-ints",+ updateCfg = unsafeMath,+ info = "Enable all unsafe Int math optimizations. Equivalent to "+ ++ "--opt-unsafe-mult --opt-vague-ints"},+ ArgSpec { optName = "opt-unsafe-mult",+ updateCfg = unsafeMul,+ info = "Use Javascript's built-in multiplication operator for "+ ++ "fixed precision integer multiplication. This speeds "+ ++ "up Int multiplication by a factor of at least four, "+ ++ "but may give incorrect results when the product "+ ++ "falls outside the interval [-2^52, 2^52]."},+ ArgSpec { optName = "opt-vague-ints",+ updateCfg = vagueInts,+ info = "Int math has 53 bits of precision, but gives incorrect "+ ++ "results rather than properly wrapping around when "+ ++ "those 53 bits are exceeded. Bitwise operations still "+ ++ "only work on the lowest 32 bits. This option should "+ ++ "give a substantial performance boost for Int math "+ ++ "heavy code."},+ ArgSpec { optName = "opt-whole-program",+ updateCfg = enableWholeProgramOpts,+ info = "Perform optimizations over the whole program at link "+ ++ "time.\nMay significantly increase compilation time."},+ ArgSpec { optName = "out=",+ updateCfg = \cfg outfile -> cfg {outFile = const $ head outfile},+ info = "Write the JS blob to <arg>."},+ ArgSpec { optName = "start=asap",+ updateCfg = \cfg _ -> cfg {appStart = startASAP},+ info = "Start program immediately instead of on document load."},+ ArgSpec { optName = "verbose",+ updateCfg = \cfg _ -> cfg {verbose = True},+ info = "Display even the most obnoxious warnings."},+ ArgSpec { optName = "with-js=",+ updateCfg = \cfg args -> cfg {jsExternals = args},+ info = "Comma-separated list of .js files to include in the "+ ++ "final JS bundle."}+ ]++-- | Compose two config update functions. Be careful about using any args with+-- them though!+(|||) :: (Config -> [String] -> Config)+ -> (Config -> [String] -> Config)+ -> (Config -> [String] -> Config)+a ||| b = \cfg args -> b (a cfg args) args++-- | Don't wrap Ints.+vagueInts :: Config -> [String] -> Config+vagueInts cfg _ = cfg {wrapIntMath = id}++-- | Use fast but unsafe multiplication.+unsafeMul :: Config -> [String] -> Config+unsafeMul cfg _ = cfg {multiplyIntOp = fastMultiply}++-- | Enable all unsafe math ops. Remember to update the info text when changing+-- this!+unsafeMath :: Config -> [String] -> Config+unsafeMath = vagueInts ||| unsafeMul++-- | Enable all optimizations, both safe and unsafe.+optAllUnsafe :: Config -> [String] -> Config+optAllUnsafe = optAllSafe ||| unsafeMath++-- | Enable all safe optimizations.+optAllSafe :: Config -> [String] -> Config+optAllSafe = updateClosureCfg ||| enableWholeProgramOpts++-- | Set the path to the Closure compiler.jar to use.+updateClosureCfg :: Config -> [String] -> Config+updateClosureCfg cfg ['=':arg] =+ cfg {useGoogleClosure = Just arg}+updateClosureCfg cfg _ =+ cfg {useGoogleClosure = Just closureCompiler}++-- | Enable optimizations over the entire program.+enableWholeProgramOpts :: Config -> [String] -> Config+enableWholeProgramOpts cfg _ = cfg {wholeProgramOpts = True}++-- | Enable sloppy TCE; see Config for more info.+useSloppyTCE :: Config -> [String] -> Config+useSloppyTCE cfg _ = cfg {sloppyTCE = True}
+ src/Args.hs view
@@ -0,0 +1,53 @@+module Args (ArgSpec (..), handleArgs) where+import Data.List (partition, stripPrefix)++data ArgSpec a = ArgSpec {+ optName :: String,+ updateCfg :: a -> [String] -> a,+ info :: String+ }++-- | Updates a config based on the given list of ArgSpecs and command line+-- arguments. If --help is encountered within the arguments, we stop+-- everything and just return a help message.+handleArgs :: a -> [ArgSpec a] -> [String] -> Either String (a, [String])+handleArgs cfg specs args =+ if elem "--help" cfgargs+ then Left (printHelp specs)+ else Right (foldl (matchSpec specs) cfg (map (drop 2) cfgargs), rest)+ where+ (cfgargs, rest) = partition ((== "--") . take 2) args++matchSpec :: [ArgSpec a] -> a -> String -> a+matchSpec specs cfg arg =+ foldl updCfg cfg matchingSpecs+ where+ updCfg cfg' (spec, args) =+ updateCfg spec cfg' (commaBreak args)+ specArgs =+ map (\spec -> stripPrefix (optName spec) arg) specs+ matchingSpecs =+ map (\(s, Just a) -> (s, a)) $ filter isMatching (zip specs specArgs)+ isMatching (_, Nothing) = False+ isMatching _ = True++-- | Like 'words', except it breaks on commas instead of spaces.+commaBreak :: String -> [String]+commaBreak [] = []+commaBreak s =+ case span (/= ',') s of+ (w, ws) -> w : commaBreak (drop 1 ws)++printHelp :: [ArgSpec a] -> String+printHelp = unlines . map helpString++helpString :: ArgSpec a -> String+helpString spec =+ "--" ++ hdr ++ "\n "+ ++ info spec+ ++ "\n"+ where+ hdr =+ case last $ optName spec of+ '=' -> optName spec ++ "<arg>"+ _ -> optName spec
+ src/Control/Shell.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+-- | Simple interface for shell scripting-like tasks.+module Control.Shell ( + Shell, shell,+ mayFail,+ withEnv, getEnv, lookupEnv,+ run, run_, run', runInteractive,+ cd, cpDir, pwd, ls, mkdir, rmdir, inDirectory, isDirectory,+ withHomeDirectory, inHomeDirectory, withAppDirectory, inAppDirectory,+ isFile, rm, mv, cp, file, mtime,+ withTempFile, withTempDirectory, inTempDirectory,+ module System.FilePath,+ ) where+import Control.Applicative+import Control.Monad (ap)+import Control.Monad.IO.Class+import Data.Time.Clock+import System.FilePath+import qualified System.Process as Proc+import qualified System.Directory as Dir+import qualified System.Exit as Exit+import qualified System.IO as IO+import qualified Control.Exception as Ex+import qualified System.IO.Temp as Temp+import qualified System.Environment as Env++-- | Environment variables.+type Env = [(String, String)]++-- | Monad for running shell commands. If a command fails, the entire+-- computation is aborted unless @mayFail@ is used.+newtype Shell a = Shell {unSh :: Env -> IO (Either String a)}++instance Monad Shell where+ fail err = Shell $ \_ -> return $ Left err+ return x = Shell $ \_ -> return $ Right x+ (Shell m) >>= f = Shell $ \env -> do+ x <- m env+ case x of+ Right x' -> unSh (f x') env+ Left err -> return $ Left err++instance MonadIO Shell where+ liftIO act = Shell $ \_ -> Ex.catch (fmap Right act) exHandler++instance Applicative Shell where+ pure = return+ (<*>) = ap++instance Functor Shell where+ fmap f (Shell x) = Shell $ \env -> fmap (fmap f) (x env)++-- | Enable the user to use 'file "foo" >>= fmap reverse >>= file "bar"' as+-- syntax for reading the file 'foo', reversing the contents and writing the+-- result to 'bar'.+-- Note that this uses lazy IO in the form of read/writeFile.+class File a where+ file :: FilePath -> a++instance File (String -> Shell ()) where+ file f = liftIO . writeFile f++instance File (Shell String) where+ file f = liftIO $ readFile f++-- | Run a Shell computation. The program's working directory will be restored +-- after executing the computation.+shell :: Shell a -> IO (Either String a)+shell act = do+ dir <- Dir.getCurrentDirectory+ env <- Env.getEnvironment+ res <- unSh act env+ Dir.setCurrentDirectory dir+ return res++-- | Run a computation with a new value for an environment variable.+-- Note that this will *not* affect external commands spawned using @liftIO@+-- or which directory is considered the system temp directory.+withEnv :: String -> (String -> String) -> Shell a -> Shell a+withEnv key f (Shell act) = Shell $ \env -> do+ act $ insert env+ where+ insert (x@(k,v):xs) | k == key = (key, f v) : xs+ | otherwise = x : insert xs+ insert _ = [(key, f "")]++-- | Get the value of an environment variable. Returns Nothing if the variable +-- doesn't exist.+lookupEnv :: String -> Shell (Maybe String)+lookupEnv key = Shell $ return . Right . lookup key++-- | Get the value of an environment variable. Returns the empty string if+-- the variable doesn't exist.+getEnv :: String -> Shell String+getEnv key = maybe "" id `fmap` lookupEnv key++-- | General exception handler; any exception causes failure.+exHandler :: Ex.SomeException -> IO (Either String a)+exHandler = return . Left . show++-- | Execute an external command. No globbing, escaping or other external shell+-- magic is performed on either the command or arguments. The program's text+-- output will be returned, and not echoed to the screen.+-- The text output is read strictly, so this is not suitable for interactive+-- commands.+run :: String -> [String] -> String -> Shell String+run p args stdin = do+ (Just inp, Just out, _) <- runP p args Proc.CreatePipe Proc.CreatePipe+ liftIO $ do+ IO.hPutStr inp stdin+ IO.hClose inp+ IO.hGetContents out++-- | Like @run@, but echoes the command's text output to the screen instead of+-- returning it. Waits for the command to complete before returning.+run_ :: String -> [String] -> String -> Shell ()+run_ p args stdin = do+ (Just inp, _, pid) <- runP p args Proc.CreatePipe Proc.Inherit+ exCode <- liftIO $ do+ IO.hPutStr inp stdin+ IO.hClose inp+ Proc.waitForProcess pid+ case exCode of+ Exit.ExitFailure ec -> fail $ "Command '" ++ p ++ "' failed with error " + ++" code " ++ show ec+ _ -> return ()++-- | Create a process. Helper for @run@ and friends.+runP :: String+ -> [String]+ -> Proc.StdStream+ -> Proc.StdStream+ -> Shell (Maybe IO.Handle, Maybe IO.Handle, Proc.ProcessHandle)+runP p args stdin stdout = Shell $ \env -> do+ (inp, out, _, pid) <- Proc.createProcess (cproc env)+ return $ Right (inp, out, pid)+ where+ cproc env = Proc.CreateProcess {+ Proc.cmdspec = Proc.RawCommand p args,+ Proc.cwd = Nothing,+ Proc.env = Just env,+ Proc.std_in = stdin,+ Proc.std_out = stdout,+ Proc.std_err = Proc.Inherit,+ Proc.close_fds = False,+ Proc.create_group = False+ }++-- | Run a command and wait for it to terminate before returning its output.+run' :: String -> [String] -> String -> Shell String+run' p args stdin = do+ (Just inp, Just out, pid) <- runP p args Proc.Inherit Proc.Inherit+ exCode <- liftIO $ do+ IO.hPutStr inp stdin+ IO.hClose inp+ Proc.waitForProcess pid+ case exCode of+ Exit.ExitFailure ec -> fail $ "Command '" ++ p ++ "' failed with error " + ++" code " ++ show ec+ _ -> liftIO $ IO.hGetContents out++-- | Run an interactive process.+runInteractive :: String -> [String] -> Shell ()+runInteractive p args = do+ (_, _, pid) <- runP p args Proc.Inherit Proc.Inherit+ exitCode <- liftIO $ Proc.waitForProcess pid+ case exitCode of+ Exit.ExitFailure ec -> fail (show ec)+ _ -> return ()++-- | Change working directory.+cd :: FilePath -> Shell ()+cd = liftIO . Dir.setCurrentDirectory++-- | Get the current working directory.+pwd :: Shell FilePath+pwd = liftIO $ Dir.getCurrentDirectory++-- | Remove a file.+rm :: FilePath -> Shell ()+rm = liftIO . Dir.removeFile++-- | Rename a file.+mv :: FilePath -> FilePath -> Shell ()+mv from to = liftIO $ Dir.renameFile from to++-- | Recursively copy a directory. If the target is a directory that already+-- exists, the source directory is copied into that directory using its+-- current name.+cpDir :: FilePath -> FilePath -> Shell ()+cpDir from to = do+ todir <- isDirectory to+ if todir+ then do+ cpDir from (to </> takeBaseName from)+ else do+ cpfile <- isFile from+ if cpfile+ then do+ cp from to+ else do+ liftIO $ Dir.createDirectoryIfMissing False to+ ls from >>= mapM_ (\f -> cpDir (from </> f) (to </> f))++-- | Copy a file. Fails if the source is a directory. If the target is a+-- directory, the source file is copied into that directory using its current+-- name.+cp :: FilePath -> FilePath -> Shell ()+cp from to = do+ todir <- isDirectory to+ if todir+ then cp from (to </> takeFileName from)+ else liftIO $ Dir.copyFile from to++-- | List the contents of a directory, sans '.' and '..'.+ls :: FilePath -> Shell [FilePath]+ls dir = do+ contents <- liftIO $ Dir.getDirectoryContents dir+ return [f | f <- contents, f /= ".", f /= ".."]++-- | Get the last time the given file was modified in UTC.+mtime :: FilePath -> Shell UTCTime+mtime = liftIO . Dir.getModificationTime++-- | Create a directory. Optionally create any required missing directories as+-- well.+mkdir :: Bool -> FilePath -> Shell ()+mkdir True = liftIO . Dir.createDirectoryIfMissing True+mkdir _ = liftIO . Dir.createDirectory++-- | Recursively remove a directory. Follows symlinks, so be careful.+rmdir :: FilePath -> Shell ()+rmdir = liftIO . Dir.removeDirectoryRecursive++-- | Do something with the user's home directory.+withHomeDirectory :: (FilePath -> Shell a) -> Shell a+withHomeDirectory act = liftIO Dir.getHomeDirectory >>= act++-- | Do something *in* the user's home directory.+inHomeDirectory :: Shell a -> Shell a+inHomeDirectory act = withHomeDirectory $ \dir -> inDirectory dir act++-- | Do something with the given application's data directory.+withAppDirectory :: String -> (FilePath -> Shell a) -> Shell a+withAppDirectory app act = liftIO (Dir.getAppUserDataDirectory app) >>= act++-- | Do something *in* the given application's data directory.+inAppDirectory :: FilePath -> Shell a -> Shell a+inAppDirectory app act = withAppDirectory app $ \dir -> inDirectory dir act++-- | Execute a command in the given working directory, then restore the+-- previous working directory.+inDirectory :: FilePath -> Shell a -> Shell a+inDirectory dir act = do+ curDir <- pwd+ cd dir+ x <- act+ cd curDir+ return x++-- | Does the given path lead to a directory?+isDirectory :: FilePath -> Shell Bool+isDirectory = liftIO . Dir.doesDirectoryExist++-- | Does the given path lead to a file?+isFile :: FilePath -> Shell Bool+isFile = liftIO . Dir.doesFileExist++-- | Create a temp directory in the standard system temp directory, do+-- something with it, then remove it.+withTempDirectory :: String -> (FilePath -> Shell a) -> Shell a+withTempDirectory template act = Shell $ \env -> do+ Temp.withSystemTempDirectory template (act' env)+ where+ act' env fp = Ex.catch (unSh (act fp) env) exHandler++-- | Performs a command inside a temporary directory. The directory will be+-- cleaned up after the command finishes.+inTempDirectory :: Shell a -> Shell a+inTempDirectory = withTempDirectory "hsshell" . flip inDirectory++-- | Create a temp file in the standard system temp directory, do something+-- with it, then remove it.+withTempFile :: String -> (FilePath -> IO.Handle -> Shell a) -> Shell a+withTempFile template act = Shell $ \env -> do+ Temp.withSystemTempFile template (act' env)+ where+ act' env fp h = Ex.catch (unSh (act fp h) env) exHandler++-- | Perform an action that may fail without aborting the entire computation.+mayFail :: Shell a -> Shell (Either String a)+mayFail (Shell act) = Shell $ \env -> do+ x <- Ex.catch (act env) exHandler+ return $ Right x
+ src/Data/JSTarget.hs view
@@ -0,0 +1,17 @@+-- | Javascript subset as a target language for compilers.+module Data.JSTarget (+ module Constr, module Op, module Optimize, module Trav,+ Fingerprint, PPOpts (..), pretty, runPP, prettyProg, def,+ Arity, Comment, Shared, Name (..), Var (..), LHS, Call,+ Lit, Exp, Stm, Alt, AST (..), Module (..),+ foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar+ ) where+import Data.JSTarget.AST+import Data.JSTarget.Op as Op+import Data.JSTarget.Optimize as Optimize+import Data.JSTarget.Constructors as Constr+import Data.JSTarget.PP (pretty, runPP, prettyProg, PPOpts (..))+import Data.JSTarget.Print as Print ()+import Data.JSTarget.Binary ()+import Data.JSTarget.Traversal as Trav+import Data.Default (def)
+ src/Data/JSTarget/AST.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances #-}+module Data.JSTarget.AST where+import qualified Data.Set as S+import qualified Data.Map as M+import System.IO.Unsafe+import System.Random (randomIO)+import Data.IORef+import Data.Word+import Control.Applicative+import Data.JSTarget.Op++type Arity = Int+type Comment = String+type Reorderable = Bool++-- | Shared statements.+newtype Shared a = Shared Lbl deriving (Eq, Show)++data Name = Name String (Maybe (String, String)) deriving (Eq, Ord, Show)++class HasModule a where+ moduleOf :: a -> Maybe String+ pkgOf :: a -> Maybe String++instance HasModule Name where+ moduleOf (Name _ mmod) = fmap snd mmod+ pkgOf (Name _ mmod) = fmap fst mmod++instance HasModule Var where+ moduleOf (Foreign _) = Nothing+ moduleOf (Internal n _) = moduleOf n+ pkgOf (Foreign _) = Nothing+ pkgOf (Internal n _) = pkgOf n++-- | Representation of variables.+data Var where+ Foreign :: String -> Var+ Internal :: Name -> Comment -> Var+ deriving (Show)++instance Eq Var where+ (Foreign f1) == (Foreign f2) = f1 == f2+ (Internal i1 _) == (Internal i2 _) = i1 == i2+ _ == _ = False++instance Ord Var where+ compare (Foreign f1) (Foreign f2) = compare f1 f2+ compare (Internal i1 _) (Internal i2 _) = compare i1 i2+ compare (Foreign _) (Internal _ _) = Prelude.LT+ compare (Internal _ _) (Foreign _) = Prelude.GT++-- | Left hand side of an assignment. Normally we only assign internal vars,+-- but for some primops we need to assign array elements as well.+-- LhsExp is never reorderable.+data LHS where+ NewVar :: Reorderable -> Var -> LHS+ LhsExp :: Exp -> LHS+ deriving (Eq, Show)++-- | Distinguish between normal, optimized and method calls.+data Call where+ Normal :: Call+ Fast :: Call+ Method :: String -> Call+ deriving (Eq, Show)++-- | Literals; nothing fancy to see here.+data Lit where+ LNum :: Double -> Lit+ LStr :: String -> Lit+ LBool :: Bool -> Lit+ LInt :: Integer -> Lit+ LNull :: Lit+ deriving (Eq, Show)++-- | Expressions. Completely predictable.+data Exp where+ Var :: Var -> Exp+ Lit :: Lit -> Exp+ Not :: Exp -> Exp+ BinOp :: BinOp -> Exp -> Exp -> Exp+ Fun :: Maybe Name -> [Var] -> Stm -> Exp+ Call :: Arity -> Call -> Exp -> [Exp] -> Exp+ Index :: Exp -> Exp -> Exp+ Arr :: [Exp] -> Exp+ AssignEx :: Exp -> Exp -> Exp+ IfEx :: Exp -> Exp -> Exp -> Exp+ deriving (Eq, Show)++-- | Statements. The only mildly interesting thing here are the Case and Jump+-- constructors, which allow explicit sharing of continuations.+data Stm where+ Case :: Exp -> Stm -> [Alt] -> Shared Stm -> Stm+ Forever :: Stm -> Stm+ Assign :: LHS -> Exp -> Stm -> Stm+ Return :: Exp -> Stm+ Cont :: Stm+ Jump :: Shared Stm -> Stm+ NullRet :: Stm+ deriving (Eq, Show)++-- | Case alternatives - an expression to match and a branch.+type Alt = (Exp, Stm)++-- | Module fingerprint, containing a hash of compiler options and other things+-- that may be used to determine whether the module needs recompiling or not.+type Fingerprint = String++-- | Represents a module. A module has a name, a fingerprint, an owning+-- package, a dependency map of all its definitions, and a bunch of+-- definitions.+data Module = Module {+ modFingerprint :: !Fingerprint,+ modPackageId :: !String,+ modName :: !String,+ modDeps :: !(M.Map Name (S.Set Name)),+ modDefs :: !(M.Map Name (AST Exp))+ }++-- | Imaginary module for foreign code that may need one.+foreignModule :: Module+foreignModule = Module {+ modFingerprint = "",+ modPackageId = "",+ modName = "",+ modDeps = M.empty,+ modDefs = M.empty+ }++-- | An LHS that's guaranteed to not ever be read, enabling the pretty+-- printer to ignore assignments to it.+blackHole :: LHS+blackHole =+ LhsExp $ Var blackHoleVar++-- | The variable of the blackHole LHS.+blackHoleVar :: Var+blackHoleVar = Internal (Name "" (Just ("$blackhole", "$blackhole"))) ""++-- | An AST with local jumps.+data AST a = AST {+ astCode :: a,+ astJumps :: JumpTable+ } deriving (Show, Eq)++instance Functor AST where+ fmap f (AST ast js) = AST (f ast) js++instance Applicative AST where+ pure = return+ (AST f js) <*> (AST x js') = AST (f x) (M.union js' js)++instance Monad AST where+ return x = AST x M.empty+ (AST ast js) >>= f =+ case f ast of+ AST ast' js' -> AST ast' (M.union js' js)++-- | Returns the precedence of the top level operator of the given expression.+-- Everything that's not an operator has equal precedence, higher than any+-- binary operator.+expPrec :: Exp -> Int+expPrec (BinOp Sub (Lit (LNum 0)) _) = 500 -- 0-n is always printed as -n+expPrec (BinOp op _ _) = opPrec op+expPrec (Not _) = 500+expPrec _ = 1000++type JumpTable = M.Map Lbl Stm++data Lbl = Lbl !Word64 !Word64 deriving (Eq, Ord, Show)++{-# NOINLINE nextLbl #-}+nextLbl :: IORef Word64+nextLbl = unsafePerformIO $ newIORef 0++{-# NOINLINE lblNamespace #-}+-- | Namespace for labels, to avoid collisions when combining modules.+-- We really ought to make this f(package, module) or something, but a random+-- 64 bit unsigned int should suffice.+lblNamespace :: Word64+lblNamespace = unsafePerformIO $ randomIO++{-# NOINLINE lblFor #-}+-- | Produce a local reference to the given statement.+lblFor :: Stm -> AST Lbl+lblFor s = do+ (r, s') <- freshRef+ AST r (M.singleton r s')+ where+ freshRef = return $! unsafePerformIO $! do+ r <- atomicModifyIORef' nextLbl (\lbl -> (lbl+1, Lbl lblNamespace lbl))+ -- We need to depend on s, or GHC will hoist us out of lblFor, possibly+ -- causing circular dependencies between expressions.+ return (r, s)
+ src/Data/JSTarget/Binary.hs view
@@ -0,0 +1,148 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Binary instances for JSTarget types.+module Data.JSTarget.Binary () where+import Prelude hiding (LT, GT)+import Data.Binary+import Data.Array+import Control.Applicative+import Data.JSTarget.AST+import Data.JSTarget.Op++instance Binary a => Binary (AST a) where+ put (AST x jumps) = put x >> put jumps+ get = AST <$> get <*> get++instance Binary Module where+ put (Module fp pkgid name deps defs) =+ put fp >> put pkgid >> put name >> put deps >> put defs+ get = Module <$> get <*> get <*> get <*> get <*> get++instance Binary Var where+ put (Foreign str) = putWord8 0 >> put str+ put (Internal name comment) = putWord8 1 >> put name >> put comment++ get = do+ getWord8 >>= ([Foreign <$> get,Internal <$> get <*> get] !!) . fromIntegral++instance Binary LHS where+ put (NewVar r v) = putWord8 0 >> put r >> put v+ put (LhsExp e) = putWord8 1 >> put e+ + get = getWord8 >>= ([NewVar <$>get<*>get, LhsExp <$> get] !!) . fromIntegral++instance Binary Call where+ put Normal = putWord8 0+ put Fast = putWord8 1+ put (Method m) = putWord8 2 >> put m+ + get = getWord8 >>= ([pure Normal,pure Fast,Method <$> get] !!) . fromIntegral++instance Binary Lit where+ put (LNum d) = putWord8 0 >> put d+ put (LStr s) = putWord8 1 >> put s+ put (LBool b) = putWord8 2 >> put b+ put (LInt n) = putWord8 3 >> put n+ put (LNull) = putWord8 4+ + get = do+ t <- getWord8+ [LNum <$> get, LStr <$> get, LBool <$> get, LInt <$> get, pure LNull] !!+ fromIntegral t++instance Binary Exp where+ put (Var v) = putWord8 0 >> put v+ put (Lit l) = putWord8 1 >> put l+ put (Not ex) = putWord8 2 >> put ex+ put (BinOp op a b) = putWord8 3 >> put op >> put a >> put b+ put (Fun nam as body) = putWord8 4 >> put nam >> put as >> put body+ put (Call a c f xs) = putWord8 5 >> put a >> put c >> put f >> put xs+ put (Index arr ix) = putWord8 6 >> put arr >> put ix+ put (Arr exs) = putWord8 7 >> put exs+ put (AssignEx l r) = putWord8 8 >> put l >> put r+ put (IfEx c th el) = putWord8 9 >> put c >> put th >> put el+ + get = do+ tag <- getWord8+ case tag of+ 0 -> Var <$> get+ 1 -> Lit <$> get+ 2 -> Not <$> get+ 3 -> BinOp <$> get <*> get <*> get+ 4 -> Fun <$> get <*> get <*> get+ 5 -> Call <$> get <*> get <*> get <*> get+ 6 -> Index <$> get <*> get+ 7 -> Arr <$> get+ 8 -> AssignEx <$> get <*> get+ 9 -> IfEx <$> get <*> get <*> get+ n -> error $ "Bad tag in get :: Get Exp: " ++ show n++instance Binary Stm where+ put (Case e def alts next) =+ putWord8 0 >> put e >> put def >> put alts >> put next+ put (Forever stm) =+ putWord8 1 >> put stm+ put (Assign lhs rhs next) =+ putWord8 2 >> put lhs >> put rhs >> put next+ put (Return ex) =+ putWord8 3 >> put ex+ put (Cont) =+ putWord8 4+ put (Jump j) =+ putWord8 5 >> put j+ put (NullRet) =+ putWord8 6+ + get = do+ tag <- getWord8+ case tag of+ 0 -> Case <$> get <*> get <*> get <*> get+ 1 -> Forever <$> get+ 2 -> Assign <$> get <*> get <*> get+ 3 -> Return <$> get+ 4 -> pure Cont+ 5 -> Jump <$> get+ 6 -> pure NullRet+ n -> error $ "Bad tag in get :: Get Stm: " ++ show n++instance Binary BinOp where+ put Add = putWord8 0+ put Mul = putWord8 1+ put Sub = putWord8 2+ put Div = putWord8 3+ put Mod = putWord8 4+ put And = putWord8 5+ put Or = putWord8 6+ put Eq = putWord8 7+ put Neq = putWord8 8+ put LT = putWord8 9+ put GT = putWord8 10+ put LTE = putWord8 11+ put GTE = putWord8 12+ put Shl = putWord8 13+ put ShrL = putWord8 14+ put ShrA = putWord8 15+ put BitAnd = putWord8 16+ put BitOr = putWord8 17+ put BitXor = putWord8 18++ get = (opTbl !) <$> getWord8++instance Binary Name where+ put (Name name owner) = put name >> put owner+ get = Name <$> get <*> get++instance Binary a => Binary (Shared a) where+ put (Shared lbl) = put lbl+ get = Shared <$> get++instance Binary Lbl where+ put (Lbl namespace lbl) = put namespace >> put lbl+ get = Lbl <$> get <*> get++opTbl :: Array Word8 BinOp+opTbl =+ listArray (0, arrLen-1) es+ where+ arrLen = fromIntegral $ length es+ es = [Add, Mul, Sub, Div, Mod, And, Or, Eq, Neq, LT, GT,+ LTE, GTE, Shl, ShrL, ShrA, BitAnd, BitOr, BitXor]
+ src/Data/JSTarget/Constructors.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleInstances, OverlappingInstances, TupleSections #-}+-- | User interface for the JSTarget AST.+module Data.JSTarget.Constructors where+import Data.JSTarget.AST+import Data.JSTarget.Op+import Control.Applicative++-- | Literal types.+class Literal a where+ lit :: a -> AST Exp++instance Literal Double where+ lit = pure . Lit . LNum++instance Literal Integer where+ lit = pure . Lit . LInt++instance Literal Bool where+ lit = pure . Lit . LBool++instance Literal [Char] where+ lit = pure . Lit . LStr++instance Literal a => Literal [a] where+ lit xs = Arr <$> mapM lit xs++instance Literal Exp where+ lit = pure++instance Literal Var where+ lit = pure . Var++litN :: Double -> AST Exp+litN = lit++-- | Create a foreign variable. Foreign vars will not be subject to any name+-- mangling.+foreignVar :: String -> Var+foreignVar = Foreign++-- | A regular, internal variable. Subject to name mangling.+internalVar :: Name -> String -> Var+internalVar = Internal++-- | Create a name, qualified or not.+name :: String -> Maybe (String, String) -> Name+name = Name++-- | A variable expression, for convenience.+var :: Name -> String -> AST Exp+var n comment = pure $ Var $ internalVar n comment++-- | Turn a Var into an expression.+varExp :: Var -> AST Exp+varExp = pure . Var++-- | Call to a native method on an object. Always saturated.+callMethod :: AST Exp -> String -> [AST Exp] -> AST Exp+callMethod obj meth args =+ Call 0 (Method meth) <$> obj <*> sequence args++-- | Foreign function call. Always saturated.+callForeign :: String -> [AST Exp] -> AST Exp+callForeign f = fmap (Call 0 Fast (Var $ foreignVar f)) . sequence++-- | A normal function call. May be unsaturated. A saturated call is always+-- turned into a fast call.+call :: Arity -> AST Exp -> [AST Exp] -> AST Exp+call arity f xs = do+ foldApp <$> (Call (arity - length xs) Normal <$> f <*> sequence xs)++callSaturated :: AST Exp -> [AST Exp] -> AST Exp+callSaturated f xs = Call 0 Fast <$> f <*> sequence xs++-- | "Fold" nested function applications into one, turning them into fast calls+-- if they turn out to be saturated.+foldApp :: Exp -> Exp+foldApp (Call arity Normal (Call _ Normal f args) args') =+ foldApp (Call arity Normal f (args ++ args'))+foldApp (Call arity Normal f args) | arity == 0 =+ Call arity Fast f args+foldApp ex =+ ex++-- | Create a thunk.+thunk :: AST Stm -> AST Exp+thunk stm = callForeign "T" [Fun Nothing [] <$> stm]++-- | Evaluate an expression that may or may not be a thunk.+eval :: AST Exp -> AST Exp+eval = callForeign "E" . (:[])++-- | A binary operator.+binOp :: BinOp -> AST Exp -> AST Exp -> AST Exp+binOp op a b = BinOp op <$> a <*> b++-- | Negate an expression.+not_ :: AST Exp -> AST Exp+not_ = fmap Not++-- | Index into an array.+index :: AST Exp -> AST Exp -> AST Exp+index arr ix = Index <$> arr <*> ix++-- | Create a function.+fun :: [Var] -> AST Stm -> AST Exp+fun args = fmap (Fun Nothing args)++-- | Create an array of expressions.+array :: [AST Exp] -> AST Exp+array = fmap Arr . sequence++-- | Case statement.+-- Takes a scrutinee expression, a default alternative, a list of more+-- specific alternatives, and a continuation statement. The continuation+-- will be explicitly shared among all the alternatives.+case_ :: AST Exp+ -> (AST Stm -> AST Stm)+ -> [(AST Exp, AST Stm -> AST Stm)]+ -> AST Stm+ -> AST Stm+case_ ex def alts cont = do+ ex' <- ex+ shared <- cont >>= lblFor+ let jmp = pure $ Jump (Shared shared)+ def' <- def jmp+ alts' <- sequence [(,) <$> x <*> s jmp | (x, s) <- alts]+ pure $ Case ex' def' alts' (Shared shared)++-- | Return from a function. Only statement that doesn't take a continuation.+ret :: AST Exp -> AST Stm+ret = fmap Return++-- | Create a new var with a new value.+newVar :: Reorderable -> Var -> AST Exp -> AST Stm -> AST Stm+newVar r lhs = liftA2 $ \rhs -> Assign (NewVar r lhs) rhs++-- | Assignment without var.+assign :: AST Exp -> AST Exp -> AST Stm -> AST Stm+assign = liftA3 $ \lhs rhs -> Assign (LhsExp lhs) rhs++-- | Assignment expression.+assignEx :: AST Exp -> AST Exp -> AST Exp+assignEx = liftA2 AssignEx++-- | Terminate a statement without doing anything at all.+nullRet :: AST Stm+nullRet = pure NullRet
+ src/Data/JSTarget/Op.hs view
@@ -0,0 +1,68 @@+module Data.JSTarget.Op where+import Prelude hiding (GT, LT)++data BinOp+ = Add+ | Mul+ | Sub+ | Div+ | Mod+ | And+ | Or+ | Eq+ | Neq+ | LT+ | GT+ | LTE+ | GTE+ | Shl+ | ShrL+ | ShrA+ | BitAnd+ | BitOr+ | BitXor+ deriving (Eq)++instance Show BinOp where+ show Add = "+"+ show Mul = "*"+ show Sub = "-"+ show Div = "/"+ show Mod = "%"+ show And = "&&"+ show Or = "||"+ show Eq = "=="+ show Neq = "!="+ show LT = "<"+ show GT = ">"+ show LTE = "<="+ show GTE = ">="+ show Shl = "<<"+ show ShrL = ">>>"+ show ShrA = ">>"+ show BitAnd = "&"+ show BitOr = "|"+ show BitXor = "^"++-- | Returns the precedence of the given operator as an int. Higher number+-- means higher priority.+opPrec :: BinOp -> Int+opPrec Mul = 100+opPrec Div = 100+opPrec Mod = 100+opPrec Add = 70+opPrec Sub = 70+opPrec Shl = 60+opPrec ShrA = 60+opPrec ShrL = 60+opPrec LT = 50+opPrec GT = 50+opPrec LTE = 50+opPrec GTE = 50+opPrec Eq = 30+opPrec Neq = 30+opPrec BitAnd = 25+opPrec BitXor = 24+opPrec BitOr = 23+opPrec And = 20+opPrec Or = 10
+ src/Data/JSTarget/Optimize.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE PatternGuards, TupleSections, DoAndIfThenElse #-}+-- | Optimizations over the JSTarget AST.+module Data.JSTarget.Optimize (+ optimizeFun, tryTernary, topLevelInline+ ) where+import Data.JSTarget.AST+import Data.JSTarget.Op+import Data.JSTarget.Traversal+import Control.Applicative+import qualified Data.Map as M+import qualified Data.Set as S++-- TODO: tryTernary may inline calls that would otherwise be in tail position+-- which is something we'd really like to avoid.++optimizeFun :: Var -> AST Exp -> AST Exp+optimizeFun f (AST ast js) =+ flip runTravM js $ do+ shrinkCase ast+ >>= inlineAssigns True+ >>= inlineReturns+ >>= tailLoopify f++topLevelInline :: AST Stm -> AST Stm+topLevelInline (AST ast js) = runTravM (inlineAssigns False ast) js++-- | Attempt to turn two case branches into a ternary operator expression.+tryTernary :: Var+ -> AST Exp+ -> AST Exp+ -> (AST Stm -> AST Stm)+ -> [(AST Exp, AST Stm -> AST Stm)]+ -> Maybe (AST Exp)+tryTernary self scrut retEx def [(m, alt)] =+ case runTravM opt allJumps of+ AST (Just ex) js -> Just (AST ex js)+ _ -> Nothing+ where+ selfOccurs (Exp (Var v)) = v == self+ selfOccurs _ = False+ def' = def $ Return <$> retEx+ alt' = alt $ Return <$> retEx+ AST _ allJumps = scrut >> m >> def' >> alt'+ opt = do+ -- Make sure the return expression is used somewhere, then cut away all+ -- useless assignments. If what's left is a single Return statement,+ -- we have a pure expression suitable for use with ?:.+ def'' <- inlineAssignsLocal $ astCode def'+ alt'' <- inlineAssignsLocal $ astCode alt'+ -- If self occurs in either branch, we can't inline or we risk ruining+ -- tail call elimination.+ selfInDef <- occurrences (const True) selfOccurs def''+ selfInAlt <- occurrences (const True) selfOccurs alt''+ case (selfInDef + selfInAlt, def'', alt'') of+ (Never, Return el, Return th) ->+ return $ Just $ IfEx (BinOp Eq (astCode scrut) (astCode m)) th el+ _ ->+ return Nothing+tryTernary _ _ _ _ _ =+ Nothing++-- | How many times does an expression satisfying the given predicate occur in+-- an AST (including jumps)?+occurrences :: JSTrav ast+ => (ASTNode -> Bool)+ -> (ASTNode -> Bool)+ -> ast+ -> TravM Occs+occurrences tr p ast =+ foldJS trav count Never ast+ where+ trav n node = tr node && n < Lots -- Stop traversal if we're already >1.+ count n node | p node = pure $ n + Once+ count n _ = pure n++-- | Replace all occurrences of an expression, without entering shared code+-- paths. IO ordering is preserved even when entering lambdas thanks to+-- State# RealWorld.+replaceEx :: JSTrav ast => (ASTNode -> Bool) -> Exp -> Exp -> ast -> TravM ast+replaceEx trav old new =+ mapJS trav (\x -> if x == old then pure new else pure x) pure++-- | Inline assignments where the assignee is only ever used once.+-- Does not inline anything into a shared code path, as that would break+-- things horribly.+-- Ignores LhsExp assignments, since we only introduce those when we actually+-- care about the assignment side effect.+inlineAssigns :: JSTrav ast => Bool -> ast -> TravM ast+inlineAssigns blackholeOK ast = do+ inlinable <- gatherInlinable ast+ mapJS (const True) return (inl inlinable) ast+ where+ varOccurs lhs (Exp (Var lhs')) = lhs == lhs'+ varOccurs _ _ = False+ inl m keep@(Assign (NewVar mayReorder lhs) ex next) = do+ occursRec <- occurrences (const True) (varOccurs lhs) ex+ if occursRec == Never+ then do+ occursLocal <- occurrences (not <$> isShared) (varOccurs lhs) next+ case M.lookup lhs m of+ Just occ | occ == occursLocal ->+ case occ of+ -- Never-used symbols don't need assignment.+ Never | blackholeOK -> do+ return (Assign blackHole ex next)+ -- Inline of any non-lambda value+ Once | mayReorder -> do+ replaceEx (not <$> isShared) (Var lhs) ex next+ -- Don't inline lambdas, but use less verbose syntax.+ _ | Fun Nothing vs body <- ex,+ Internal lhsname _ <- lhs -> do+ return $ Assign blackHole (Fun (Just lhsname) vs body) next+ _ -> do+ return keep+ _ ->+ return keep+ else do+ return keep+ inl _ stm = return stm++-- | Gather a map of all inlinable symbols; that is, the once that are used+-- exactly once.+gatherInlinable :: JSTrav ast => ast -> TravM (M.Map Var Occs)+gatherInlinable =+ fmap (M.filter (< Lots)) . foldJS (\_ _ -> True) countOccs M.empty+ where+ updVar (Just occs) = Just (occs+Once)+ updVar _ = Just Once+ updVarAss (Just o) = Just o+ updVarAss _ = Just Never+ countOccs m (Exp (Var v@(Internal _ _))) =+ pure $ M.alter updVar v m+ countOccs m (Stm (Assign (NewVar _ v) _ _)) =+ pure $ M.alter updVarAss v m+ countOccs m _ =+ pure m++-- | Like `inlineAssigns`, but doesn't care what happens beyond a jump.+inlineAssignsLocal :: JSTrav ast => ast -> TravM ast+inlineAssignsLocal ast = do+ mapJS (\n -> not (isLambda n || isShared n)) return inl ast+ where+ varOccurs lhs (Exp (Var lhs')) = lhs == lhs'+ varOccurs _ _ = False+ inl keep@(Assign (NewVar mayReorder lhs) ex next) = do+ occurs <- occurrences (const True) (varOccurs lhs) next+ occurs' <- occurrences (const True) (varOccurs lhs) ex+ case occurs + occurs' of+ Never ->+ return (Assign blackHole ex next)+ -- Don't inline lambdas at the moment, but use less verbose syntax.+ _ | Fun Nothing vs body <- ex,+ Internal lhsname _ <- lhs ->+ return $ Assign blackHole (Fun (Just lhsname) vs body) next+ Once | mayReorder ->+ -- can't be recursive - inline+ replaceEx (not <$> isShared) (Var lhs) ex next+ _ ->+ -- Really nothing to be done here.+ return keep+ inl stm = return stm++-- | Turn sequences like `v0 = foo; v1 = v0; v2 = v1; return v2;` into a+-- straightforward `return foo;`.+-- Ignores LhsExp assignments, since we only introduce those when we actually+-- care about the assignment side effect.+inlineReturns :: JSTrav ast => ast -> TravM ast+inlineReturns ast = do+ (s, ast') <- foldMapJS (\_ _ -> True) pure2 foldRet S.empty ast+ mapM_ (flip putRef NullRet) $ S.toList s+ return ast'+ where+ pure2 s x = pure (s,x)+ foldRet s (Assign (NewVar _ lhs) rhs (Return (Var v))) | v == lhs = do+ return (s, Return rhs)+ foldRet s keep@(Assign (NewVar _ lhs) rhs (Jump (Shared lbl))) = do+ next <- getRef lbl+ case next of+ Return (Var v) | v == lhs ->+ return (S.insert lbl s, Return rhs)+ _ ->+ return (s, keep)+ foldRet s keep = do+ return (s, keep)++-- | Inline all occurrences of the given shared code path.+-- Use with caution - preferrably not at all!+inlineShared :: JSTrav ast => Lbl -> ast -> TravM ast+inlineShared lbl =+ mapJS (const True) pure inl+ where+ inl (Jump (Shared lbl')) | lbl == lbl' = getRef lbl+ inl s = pure s++-- | Shrink case statements as much as possible.+shrinkCase :: JSTrav ast => ast -> TravM ast+shrinkCase =+ mapJS (const True) pure shrink+ where+ shrink (Case _ def [] next@(Shared lbl))+ | def == Jump next = getRef lbl+ | otherwise = inlineShared lbl def+ shrink stm = return stm++-- | Turn tail recursion on the given var into a loop, if possible.+-- Tail recursive functions that create closures turn into:+-- function f(a', b', c') {+-- while(1) {+-- var r = (function(a, b, c) {+-- a' = a; b' = b; c' = c;+-- })(a', b', c');+-- if(r != null) {+-- return r;+-- }+-- }+-- }+tailLoopify :: Var -> Exp -> TravM Exp+tailLoopify f fun@(Fun mname args body) = do+ tailrecs <- occurrences (not <$> isLambda) isTailRec body+ if tailrecs > Never+ then do+ needToCopy <- createsClosures body+ case needToCopy of+ True -> do+ let args' = map newName args+ ret = Return (Lit $ LNull)+ b <- mapJS (not <$> isLambda) pure (replaceByAssign ret args') body+ let (AST nullRetLbl _) = lblFor NullRet+ nn = newName f+ nv = NewVar False nn+ body' =+ Forever $+ Assign nv (Call 0 Fast (Fun Nothing args b) (map Var args'))$+ Case (Var nn) (Return (Var nn)) [(Lit $ LNull, NullRet)] $+ (Shared nullRetLbl)+ putRef nullRetLbl NullRet+ return $ Fun mname args' body'+ False -> do+ let c = Cont+ body' <- mapJS (not <$> isLambda) pure (replaceByAssign c args) body+ return $ Fun mname args (Forever body')+ else do+ return fun+ where+ isTailRec (Stm (Return (Call 0 _ (Var f') _))) = f == f'+ isTailRec _ = False+ + -- Only traverse until we find a closure+ createsClosures = foldJS (\acc _ -> not acc) isClosure False+ isClosure _ (Exp (Fun _ _ _)) = pure True+ isClosure acc _ = pure acc++ -- Assign any changed vars, then loop.+ replaceByAssign end as (Return (Call 0 _ (Var f') as')) | f == f' = do+ let (first, second) = foldr assignUnlessEqual (id, end) (zip as as')+ return $ first second+ replaceByAssign _ _ stm =+ return stm++ -- Assign an expression to a variable, unless that expression happens to+ -- be the variable itself.+ assignUnlessEqual (v, (Var v')) (next, final) | v == v' =+ (next, final)+ assignUnlessEqual (v, x) (next, final) | any (x `contains`) args =+ (Assign (NewVar False (newName v)) x . next,+ Assign (LhsExp (Var v)) (Var $ newName v) final)+ | otherwise =+ (Assign (LhsExp (Var v)) x . next, final)+ + newName (Internal (Name n mmod) _) =+ Internal (Name (' ':n) mmod) ""+ newName n =+ n+ + contains (Var v) var = v == var+ contains (Lit _) _ = False+ contains (Not x) var = x `contains` var+ contains (BinOp _ a b) var = a `contains` var || b `contains` var+ contains (Fun _ _ _) _ = False+ contains (Call _ _ f' xs) var = f' `contains` var||any (`contains` var) xs+ contains (Index a i) var = a `contains` var || i `contains` var+ contains (Arr xs) var = any (`contains` var) xs+ contains (AssignEx l r) var = l `contains` var || r `contains` var+ contains (IfEx c t e) var = any (`contains` var) [c,t,e]+tailLoopify _ fun = do+ return fun
+ src/Data/JSTarget/PP.hs view
@@ -0,0 +1,196 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings, FlexibleInstances,+ GeneralizedNewtypeDeriving #-}+-- | JSTarget pretty printing machinery. The actual printing happens in +-- Data.JSTarget.Print.+module Data.JSTarget.PP where+import Data.Default+import Data.Monoid+import Data.String+import Data.List (foldl')+import Data.Array+import Control.Monad+import Control.Applicative+import qualified Data.Map as M+import qualified Data.ByteString.Lazy as BS+import Data.ByteString.Lazy.Builder+import Data.ByteString.Lazy.Builder.ASCII+import Data.JSTarget.AST (AST (..), Name (..), JumpTable, Lbl, Stm)+import Data.JSTarget.Traversal (JSTrav)++-- | Pretty-printing options+data PPOpts = PPOpts {+ nameComments :: Bool, -- ^ Emit comments for names, where available?+ useIndentation :: Bool, -- ^ Should we indent at all?+ indentStr :: Builder, -- ^ String to use for each step of indentation+ useNewlines :: Bool, -- ^ Use line breaks?+ useSpaces :: Bool -- ^ Use spaces other than where necessary?+ }++type IndentLvl = Int++-- | Final name for symbols. This name is what actually appears in the final+-- JS dump, albeit "base 62"-encoded.+newtype FinalName = FinalName Int deriving (Ord, Eq, Enum, Show)+type NameSupply = (FinalName, M.Map Name FinalName)++emptyNS :: NameSupply+emptyNS = (FinalName 0, M.empty)++newtype PP a = PP {unPP :: PPOpts+ -> IndentLvl+ -> NameSupply+ -> JumpTable+ -> Builder+ -> (NameSupply, Builder, a)}++instance Monad PP where+ PP m >>= f = PP $ \opts indentlvl ns js b ->+ case m opts indentlvl ns js b of+ (ns', b', x) -> unPP (f x) opts indentlvl ns' js b'+ return x = PP $ \_ _ ns _ b -> (ns, b, x)++instance Applicative PP where+ pure = return+ (<*>) = ap++instance Functor PP where+ fmap f p = p >>= return . f++-- | Convenience operator for using the PP () IsString instance.+(.+.) :: PP () -> PP () -> PP ()+(.+.) = (>>)+infixl 1 .+.++instance Default PPOpts where+ def = PPOpts {+ nameComments = False,+ useIndentation = False,+ indentStr = " ",+ useNewlines = False,+ useSpaces = False+ }++debugPPOpts :: PPOpts+debugPPOpts = def {+ nameComments = True,+ useIndentation = True,+ indentStr = " ",+ useNewlines = True,+ useSpaces = True+ }++-- | Generate the final name for a variable.+finalNameFor :: Name -> PP FinalName+finalNameFor n = PP $ \_ _ ns@(nextN, m) _ b ->+ case M.lookup n m of+ Just n' -> (ns, b, n')+ _ -> ((succ nextN, M.insert n nextN m), b, nextN)++-- | Look up a shared reference.+lookupLabel :: Lbl -> PP Stm+lookupLabel lbl = PP $ \_ _ ns js b -> (ns, b, js M.! lbl)++-- | Returns the value of the given pretty-printer option.+getOpt :: (PPOpts -> a) -> PP a+getOpt f = PP $ \opts _ ns _ b -> (ns, b, f opts)++-- | Runs the given printer iff the specifiet option is True.+whenOpt :: (PPOpts -> Bool) -> PP () -> PP ()+whenOpt f p = getOpt f >>= \x -> when x p++-- | Pretty print an AST.+pretty :: (JSTrav a, Pretty a) => PPOpts -> AST a -> BS.ByteString+pretty opts (AST ast js) =+ case runPP opts js (pp ast) of+ (b, _) -> toLazyByteString b++-- | Run a pretty printer.+runPP :: PPOpts -> JumpTable -> PP a -> (Builder, a)+runPP opts js p =+ case unPP p opts 0 emptyNS js mempty of+ (_, b, x) -> (b, x)++-- | Pretty-print a program and return the final name for its entry point.+prettyProg :: Pretty a => PPOpts -> Name -> AST a -> (Builder, Builder)+prettyProg opts mainSym (AST ast js) = runPP opts js $ do+ pp ast+ buildFinalName <$> finalNameFor mainSym++-- | Turn a FinalName into a Builder.+buildFinalName :: FinalName -> Builder+buildFinalName (FinalName 0) =+ string7 "_0"+buildFinalName (FinalName fn) =+ char7 '_' <> go fn mempty+ where+ arrLen = 62+ chars = listArray (0,arrLen-1)+ $ "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"+ go 0 acc = acc+ go n acc = let (rest, ix) = n `quotRem` arrLen + in go rest (char7 (chars ! ix) <> acc)++-- | Indent the given builder another step.+indent :: PP a -> PP a+indent (PP p) = PP $ \opts indentlvl ns b ->+ if useIndentation opts+ then p opts (indentlvl+1) ns b+ else p opts 0 ns b++class Buildable a where+ put :: a -> PP ()++instance Buildable Builder where+ put x = PP $ \_ _ ns _ b -> (ns, b <> x, ())+instance Buildable String where+ put = put . stringUtf8+instance Buildable Char where+ put = put . char7+instance Buildable Int where+ put = put . intDec+instance Buildable Double where+ put d =+ case round d of+ n | fromIntegral n == d -> put $ intDec n+ | otherwise -> put $ doubleDec d+instance Buildable Integer where+ put = put . integerDec+instance Buildable Bool where+ put x = put $ if x then string7 "true" else string7 "false"++-- | Emit indentation up to the current level.+ind :: PP ()+ind = PP $ \opts indentlvl ns _ b ->+ (ns, foldl' (<>) b (replicate indentlvl (indentStr opts)), ())++-- | A space character.+sp :: PP ()+sp = whenOpt useSpaces $ put ' '++-- | A newline character.+newl :: PP ()+newl = whenOpt useNewlines $ put '\n'++-- | Indent the given builder and terminate it with a newline.+line :: PP () -> PP ()+line p = do+ ind >> p+ whenOpt useNewlines $ put '\n'++-- | Pretty print a list with the given separator.+ppList :: Pretty a => PP () -> [a] -> PP ()+ppList sep (x:xs) =+ foldl' (\l r -> l >> sep >> pp r) (pp x) xs+ppList _ _ =+ return ()++instance IsString Builder where+ fromString = stringUtf8++instance IsString (PP ()) where+ fromString = put . stringUtf8++-- | Pretty-printer class. Each part of the AST needs an instance of this.+class Pretty a where+ pp :: a -> PP ()
+ src/Data/JSTarget/Print.hs view
@@ -0,0 +1,204 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings #-}+module Data.JSTarget.Print () where+import Prelude hiding (LT, GT)+import Data.JSTarget.AST+import Data.JSTarget.Op+import Data.JSTarget.PP as PP+import Data.ByteString.Lazy.Builder+import Data.Monoid+import Control.Monad++instance Pretty Var where+ pp (Foreign name) =+ put $ string7 name+ pp (Internal name comment) = do+ pp name+ doComment <- getOpt nameComments+ when (doComment && not (null comment)) $+ put $ "/* " <> stringUtf8 comment <> " */"++instance Pretty Name where+ pp name = finalNameFor name >>= put . buildFinalName++instance Pretty LHS where+ pp (NewVar _ v) = "var " .+. pp v+ pp (LhsExp ex) = pp ex++instance Pretty Lit where+ pp (LNum d) = put d+ pp (LStr s) = "\"" .+. put (fixQuotes s) .+. "\""+ where+ fixQuotes ('\\':'x':xs) = '\\':'x' : fixQuotes xs+ fixQuotes ('\\':'u':xs) = '\\':'u' : fixQuotes xs+ fixQuotes ('\\':xs) = '\\':'\\' : fixQuotes xs+ fixQuotes ('"':xs) = '\\':'"' : fixQuotes xs+ fixQuotes ('\'':xs) = '\\':'\'' : fixQuotes xs+ fixQuotes ('\n':xs) = '\\':'n' : fixQuotes xs+ fixQuotes (x:xs) = x : fixQuotes xs+ fixQuotes _ = []+ pp (LBool b) = put b+ pp (LInt n) = put n+ pp (LNull) = "null"++-- | Default separator; comma followed by space, if spaces are enabled.+sep :: PP ()+sep = "," .+. sp++instance Pretty Exp where+ pp (Var v) =+ pp v+ pp (Lit l) =+ pp l+ pp (Not ex) =+ case neg ex of+ Just ex' -> pp ex'+ _ -> if expPrec (Not ex) > expPrec ex+ then "!(" .+. pp ex .+. ")"+ else "!" .+. pp ex+ pp (BinOp op a b) =+ opParens op a b+ pp (Fun mname args body) = do+ "function" .+. lambdaname .+. "(" .+. ppList sep args .+. "){" .+. newl+ indent $ pp body+ ind .+. "}"+ where+ lambdaname = maybe "" (\n -> " " .+. pp n) mname+ pp (Call _ call f args) = do+ case call of+ Normal -> "A(" .+. pp f .+. ",[" .+. ppList sep args .+. "])"+ Fast -> ppCallFun f .+. "(" .+. ppList sep args .+. ")"+ Method m -> pp f .+. put ('.':m) .+. "(" .+. ppList sep args .+. ")"+ where+ ppCallFun fun@(Fun _ _ _) = "(" .+. pp fun .+. ")"+ ppCallFun fun = pp fun+ pp (Index arr ix) = do+ pp arr .+. "[" .+. pp ix .+. "]"+ pp (Arr exs) = do+ "[" .+. ppList sep exs .+. "]"+ pp (AssignEx l r) = do+ pp l .+. sp .+. "=" .+. sp .+. pp r+ pp (IfEx c th el) = do+ pp c .+. sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el++instance Pretty (Var, Exp) where+ pp (v, ex) = pp v .+. sp .+. "=" .+. sp .+. pp ex++-- | Print a series of NewVars at once, to avoid unnecessary "var" keywords.+ppAssigns :: Stm -> PP ()+ppAssigns stm = do+ line $ "var " .+. ppList sep assigns .+. ";"+ pp next+ where+ (assigns, next) = gather [] stm+ gather as (Assign (NewVar _ v) ex nxt) = gather ((v, ex):as) nxt+ gather as nxt = (reverse as, nxt)++-- | Returns the final statement in a case branch.+finalStm :: Stm -> PP Stm+finalStm s =+ case s of+ Assign _ _ s' -> finalStm s'+ Case _ _ _ (Shared l) -> lookupLabel l >>= finalStm+ Forever s' -> finalStm s'+ _ -> return s++instance Pretty Stm where+ pp (Case cond def alts (Shared nextRef)) = do+ prettyCase cond def alts+ lookupLabel nextRef >>= pp+ pp (Forever stm) = do+ line "while(1){"+ indent $ pp stm+ line "}"+ pp s@(Assign lhs ex next) = do+ case lhs of+ _ | lhs == blackHole ->+ line (pp ex .+. ";") >> pp next+ NewVar _ _ ->+ ppAssigns s+ LhsExp _ ->+ line (pp lhs .+. sp .+. "=" .+. sp .+. pp ex .+. ";") >> pp next+ pp (Return ex) = do+ line $ "return " .+. pp ex .+. ";"+ pp (Cont) = do+ line "continue;"+ pp (Jump _) = do+ -- Jumps are essentially fallthroughs which keep track of their+ -- continuation to make analysis and optimization easier.+ return ()+ pp (NullRet) = do+ return ()++neg :: Exp -> Maybe Exp+neg (BinOp Eq a b) = Just $ BinOp Neq a b+neg (BinOp Neq a b) = Just $ BinOp Eq a b+neg (BinOp GT a b) = Just $ BinOp LTE a b+neg (BinOp LT a b) = Just $ BinOp GTE a b+neg (BinOp GTE a b) = Just $ BinOp LT a b +neg (BinOp LTE a b) = Just $ BinOp GT a b+neg _ = Nothing++-- | Turn eligible case statements into if statements.+prettyCase :: Exp -> Stm -> [Alt] -> PP ()+prettyCase cond def [(con, branch)] = do+ case (def, branch) of+ (_, NullRet) -> do+ line $ "if(" .+. pp (neg' (test con)) .+. "){"+ indent $ pp def+ line "}"+ (NullRet, _) -> do+ line $ "if(" .+. pp (test con) .+. "){"+ indent $ pp branch+ line "}"+ _ -> do+ line $ "if(" .+. pp (test con) .+."){"+ indent $ pp branch+ line "}else{"+ indent $ pp def+ line "}"+ where+ neg' c = maybe (Not c) id $ neg c + test (Lit (LBool True)) = cond+ test (Lit (LBool False)) = Not cond+ test (Lit (LNum 0)) = Not cond+ test c = BinOp Eq cond c+prettyCase _ def [] = do+ pp def+prettyCase cond def alts = do+ line $ "switch(" .+. pp cond .+. "){"+ indent $ do+ mapM_ pp alts+ line $ "default:"+ indent $ pp def+ line "}"++instance Pretty Alt where+ pp (con, branch) = do+ line $ "case " .+. pp con .+. ":"+ indent $ do+ pp branch+ s <- finalStm branch+ case s of+ Return _ -> return ()+ Cont -> return ()+ _ -> line "break;";++opParens :: BinOp -> Exp -> Exp -> PP ()+opParens Sub a (BinOp Sub (Lit (LNum 0)) b) =+ opParens Add a b+opParens Sub a (Lit (LNum n)) | n < 0 =+ opParens Add a (Lit (LNum (-n)))+opParens Sub (Lit (LNum 0)) b =+ case b of+ BinOp _ _ _ -> "-(" .+. pp b .+. ")"+ _ -> "-" .+. pp b+opParens op a b = do+ let bparens = case b of+ Lit (LNum n) | n < 0 -> \x -> "(".+. pp x .+. ")"+ _ -> parens+ parens a >> put (string7 $ show op) >> bparens b+ where+ parens x = if expPrec x < opPrec op+ then "(" .+. pp x .+. ")"+ else pp x
+ src/Data/JSTarget/Traversal.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE FlexibleInstances, TupleSections, PatternGuards #-}+-- | Generic traversal of JSTarget AST types.+module Data.JSTarget.Traversal where+import Control.Applicative+import Control.Monad+import Data.JSTarget.AST+import Data.Map as M ((!), insert)++-- | AST nodes we'd like to fold and map over.+data ASTNode = Exp Exp | Stm Stm | Label Lbl++newtype TravM a = T (JumpTable -> (JumpTable, a))+instance Monad TravM where+ return x = T $ \js -> (js, x)+ T m >>= f = T $ \js ->+ case m js of+ (js', x) | T f' <- f x -> f' js'++instance Applicative TravM where+ pure = return+ (<*>) = ap++instance Functor TravM where+ fmap f (T m) = T $ \js -> fmap f (m js)++runTravM :: TravM a -> JumpTable -> AST a+runTravM (T f) js = case f js of (js', x) -> AST x js'++getRef :: Lbl -> TravM Stm+getRef lbl = T $ \js -> (js, js M.! lbl)++putRef :: Lbl -> Stm -> TravM ()+putRef lbl stm = T $ \js -> (M.insert lbl stm js, ())++class Show ast => JSTrav ast where+ -- | Bottom up transform over an AST.+ foldMapJS :: (a -> ASTNode -> Bool) -- ^ Enter node?+ -> (a -> Exp -> TravM (a, Exp)) -- ^ Exp to Exp mapping.+ -> (a -> Stm -> TravM (a, Stm)) -- ^ Stm to Stm mapping.+ -> a -- ^ Starting accumulator.+ -> ast -- ^ AST to map over.+ -> TravM (a, ast)++ -- | Bottom up fold of an AST.+ foldJS :: (a -> ASTNode -> Bool) -- ^ Should the given node be entered?+ -- The step function is always applied+ -- to the current node, however.+ -> (a -> ASTNode -> TravM a) -- ^ Step function.+ -> a -- ^ Initial value.+ -> ast -- ^ AST to fold over.+ -> TravM a++mapJS :: JSTrav ast+ => (ASTNode -> Bool)+ -> (Exp -> TravM Exp)+ -> (Stm -> TravM Stm)+ -> ast+ -> TravM ast+mapJS tr fe fs ast =+ snd <$> foldMapJS (const tr) (const' fe) (const' fs) () ast+ where+ const' f _ x = ((),) <$> f x++instance JSTrav a => JSTrav [a] where+ foldMapJS tr fe fs acc ast =+ go (acc, []) ast+ where+ go (a, xs') (x:xs) = do+ (a', x') <- foldMapJS tr fe fs a x+ go (a', x':xs') xs+ go (a, xs) _ = do+ return (a, reverse xs)+ foldJS tr f acc ast = foldM (foldJS tr f) acc ast++instance JSTrav Exp where+ foldMapJS tr fe fs acc ast = do+ (acc', x) <- if tr acc (Exp ast)+ then do+ case ast of+ v@(Var _) -> do+ pure (acc, v)+ l@(Lit _) -> do+ pure (acc, l)+ Not ex -> do+ fmap Not <$> mapEx acc ex+ BinOp op a b -> do+ (acc', a') <- mapEx acc a+ (acc'', b') <- mapEx acc' b+ return (acc'', BinOp op a' b')+ Fun nam vs stm -> do+ fmap (Fun nam vs) <$> foldMapJS tr fe fs acc stm+ Call ar c f xs -> do+ (acc', f') <- mapEx acc f+ (acc'', xs') <- foldMapJS tr fe fs acc' xs+ return (acc'', Call ar c f' xs')+ Index arr ix -> do+ (acc', arr') <- mapEx acc arr+ (acc'', ix') <- mapEx acc' ix+ return (acc'', Index arr' ix')+ Arr exs -> do+ fmap Arr <$> foldMapJS tr fe fs acc exs+ AssignEx l r -> do+ (acc', l') <- mapEx acc l+ (acc'', r') <- mapEx acc' r+ return (acc'', AssignEx l' r')+ IfEx c th el -> do+ (acc', c') <- mapEx acc c+ (acc'', th') <- mapEx acc' th+ (acc''', el') <- mapEx acc'' el+ return (acc''', IfEx c' th' el')+ else do+ return (acc, ast)+ fe acc' x+ where+ mapEx = foldMapJS tr fe fs+ + foldJS tr f acc ast = do+ let expast = Exp ast+ acc' <- if tr acc expast+ then do+ case ast of+ Var _ -> do+ return acc+ Lit _ -> do+ return acc+ Not ex -> do+ foldJS tr f acc ex+ BinOp _ a b -> do+ acc' <- foldJS tr f acc a+ foldJS tr f acc' b+ Fun _ _ stm -> do+ foldJS tr f acc stm+ Call _ _ fun xs -> do+ acc' <- foldJS tr f acc fun+ foldJS tr f acc' xs+ Index arr ix -> do+ acc' <- foldJS tr f acc arr+ foldJS tr f acc' ix+ Arr exs -> do+ foldJS tr f acc exs+ AssignEx l r -> do+ acc' <- foldJS tr f acc l+ foldJS tr f acc' r+ IfEx c th el -> do+ acc' <- foldJS tr f acc c+ acc'' <- foldJS tr f acc' th+ foldJS tr f acc'' el+ else do+ return acc+ f acc' expast++instance JSTrav Stm where+ foldMapJS tr fe fs acc ast = do+ (acc', x) <- if tr acc (Stm ast)+ then do+ case ast of+ Case ex def alts next -> do+ (acc', ex') <- foldMapJS tr fe fs acc ex+ (acc'', def') <- foldMapJS tr fe fs acc' def+ (acc''', alts') <- foldMapJS tr fe fs acc'' alts+ (acc'''', next') <- foldMapJS tr fe fs acc''' next+ return (acc'''', Case ex' def' alts' next')+ Forever stm -> do+ fmap Forever <$> foldMapJS tr fe fs acc stm+ Assign lhs ex next -> do+ (acc', lhs') <- foldMapJS tr fe fs acc lhs+ (acc'', ex') <- foldMapJS tr fe fs acc' ex+ (acc''', next') <- foldMapJS tr fe fs acc'' next+ return (acc''', Assign lhs' ex' next')+ Return ex -> do+ fmap Return <$> foldMapJS tr fe fs acc ex+ Cont -> do+ return (acc, Cont)+ Jump stm -> do+ fmap Jump <$> foldMapJS tr fe fs acc stm+ NullRet -> do+ return (acc, NullRet)+ else do+ return (acc, ast)+ fs acc' x++ foldJS tr f acc ast = do+ let stmast = Stm ast+ acc' <- if tr acc stmast+ then do+ case ast of+ Case ex def alts next -> do+ acc' <- foldJS tr f acc ex+ acc'' <- foldJS tr f acc' def+ acc''' <- foldJS tr f acc'' alts+ foldJS tr f acc''' next+ Forever stm -> do+ foldJS tr f acc stm+ Assign lhs ex next -> do+ acc' <- foldJS tr f acc lhs+ acc'' <- foldJS tr f acc' ex+ foldJS tr f acc'' next+ Return ex -> do+ foldJS tr f acc ex+ Cont -> do+ return acc+ Jump j -> do+ foldJS tr f acc j+ NullRet -> do+ return acc+ else do+ return acc+ f acc' stmast++instance JSTrav (Exp, Stm) where+ foldMapJS tr fe fs acc (ex, stm) = do+ (acc', stm') <- foldMapJS tr fe fs acc stm+ (acc'', ex') <- foldMapJS tr fe fs acc' ex+ return (acc'', (ex', stm'))+ foldJS tr f acc (ex, stm) = do+ acc' <- foldJS tr f acc stm+ foldJS tr f acc' ex++instance JSTrav LHS where+ foldMapJS _ _ _ acc lhs@(NewVar _ _) = return (acc, lhs)+ foldMapJS t fe fs a (LhsExp ex) = fmap LhsExp <$> foldMapJS t fe fs a ex+ foldJS _ _ acc (NewVar _ _) = return acc+ foldJS tr f acc (LhsExp ex) = foldJS tr f acc ex++instance JSTrav a => JSTrav (Shared a) where+ foldMapJS tr fe fs acc sh@(Shared lbl) = do+ if (tr acc (Label lbl)) + then do+ stm <- getRef lbl+ (acc', stm') <- foldMapJS tr fe fs acc stm+ putRef lbl stm'+ return (acc', sh)+ else do+ return (acc, sh)+ foldJS tr f acc (Shared lbl) = do+ if (tr acc (Label lbl))+ then getRef lbl >>= foldJS tr f acc >>= \acc' -> f acc' (Label lbl)+ else f acc (Label lbl)++class Pred a where+ (.|.) :: a -> a -> a+ (.&.) :: a -> a -> a++instance Pred (a -> b -> Bool) where+ p .|. q = \a b -> p a b || q a b+ p .&. q = \a b -> p a b && q a b++instance Pred (a -> Bool) where+ p .|. q = \a -> p a || q a+ p .&. q = \a -> p a && q a++isShared :: ASTNode -> Bool+isShared (Label _) = True+isShared _ = False++isLambda :: ASTNode -> Bool+isLambda (Exp (Fun _ _ _)) = True+isLambda _ = False++-- | Counts occurrences. Use ints or something for a more exact count.+data Occs = Never | Once | Lots deriving (Eq, Show)++instance Ord Occs where+ compare Never Once = Prelude.LT+ compare Never Lots = Prelude.LT+ compare Once Lots = Prelude.LT+ compare a b = if a == b then Prelude.EQ else Prelude.GT++instance Num Occs where+ fromInteger n | n <= 0 = Never+ | n == 1 = Once+ | otherwise = Lots+ Never + x = x+ x + Never = x+ _ + _ = Lots++ Never * _ = Never+ _ * Never = Never+ Once * x = x+ x * Once = x+ _ * _ = Lots++ abs = id++ signum Never = Never+ signum _ = Once
+ src/Haste.hs view
@@ -0,0 +1,8 @@+module Haste (+ module Linker, module Config, module CodeGen,+ Fingerprint, Module, writeModule, readModule, readModuleFingerprint) where+import Haste.Linker as Linker+import Haste.Config as Config+import Haste.Module+import Haste.CodeGen as CodeGen+import Data.JSTarget.AST (Fingerprint, Module)
+ src/Haste/Builtins.hs view
@@ -0,0 +1,43 @@+-- | Various functions generated as builtins+module Haste.Builtins (toBuiltin) where+import GhcPlugins as P+import Data.JSTarget as J+import Control.Applicative++toBuiltin :: P.Var -> Maybe J.Var+toBuiltin v =+ case (modname, varname) of+ (Just "GHC.Prim", "coercionToken#") ->+ Just $ foreignVar "coercionToken"+ (Just "GHC.Prim", "realWorld#") ->+ Just $ foreignVar "realWorld"+ (Just "GHC.Err", "error") ->+ Just $ foreignVar "err"++ -- Everything to do with unpacking had better be built in for compactness,+ -- efficiency and space reasons.+ (Just "GHC.CString", "unpackCString#") ->+ Just $ foreignVar "unCStr"+ (Just "GHC.CString", "unpackCStringUtf8#") ->+ Just $ foreignVar "unCStr"+ (Just "GHC.CString", "unpackAppendCString#") ->+ Just $ foreignVar "unAppCStr"+ (Just "GHC.CString", "unpackFoldrCString#") ->+ Just $ foreignVar "unFoldrCStr"++ -- Primitive needs of the Haste standard library+ (Just "Haste.Prim", "toJSStr") ->+ Just $ foreignVar "toJSStr"+ (Just "Haste.Prim", "fromJSStr") ->+ Just $ foreignVar "fromJSStr"+ (Just "Haste.Prim", "jsRound") ->+ Just $ foreignVar "Math.round"+ (Just "Haste.Prim", "jsCeiling") ->+ Just $ foreignVar "Math.ceil"+ (Just "Haste.Prim", "jsFloor") ->+ Just $ foreignVar "Math.floor"+ _ | otherwise ->+ Nothing+ where+ modname = moduleNameString . moduleName <$> nameModule_maybe (varName v)+ varname = occNameString $ nameOccName $ varName v
+ src/Haste/CodeGen.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE TupleSections, PatternGuards #-}+module Haste.CodeGen (generate) where+-- Misc. stuff+import Control.Applicative+import Control.Monad+import Data.Int+import Data.Word+import Data.Char+import Data.List (partition, foldl')+import Data.Maybe (isJust)+import qualified Data.Set as S+import qualified Data.Map as M+-- STG/GHC stuff+import StgSyn+import CoreSyn (AltCon (..))+import Var (Var, varType, varName)+import IdInfo (arityInfo, IdDetails (..))+import Id (Id, idInfo, idDetails, isLocalId, isGlobalId)+import Literal as L+import FastString (unpackFS, FastString)+import ForeignCall (CCallTarget (..), ForeignCall (..), CCallSpec (..))+import PrimOp (PrimCall (..))+import OccName+import DataCon+import Module+import Name+import Type+import TysPrim+import TyCon+import BasicTypes+-- AST stuff+import Data.JSTarget as J+import Data.JSTarget.AST (Exp (..), Stm (..), LHS (..), Lit (..))+-- General Haste stuff+import Haste.Config+import Haste.Monad+import Haste.Errors+import Haste.PrimOps+import Haste.Builtins+import Haste.Util (showOutputable)++generate :: Config+ -> Fingerprint+ -> String+ -> ModuleName+ -> [StgBinding]+ -> J.Module+generate cfg fp pkgid modname binds =+ Module {+ modFingerprint = fp,+ modPackageId = pkgid,+ modName = moduleNameString modname,+ modDeps = foldl' insDep M.empty theMod,+ modDefs = foldl' insFun M.empty theMod+ }+ where+ theMod = genAST cfg modname binds+ + insFun m (_, AST (Assign (NewVar _ (Internal v _)) body _) jumps) =+ M.insert v (AST body jumps) m+ insFun m _ =+ m++ -- TODO: perhaps do dependency-based linking for externals as well?+ insDep m (ds, AST (Assign (NewVar _ (Internal v _)) _ _) _) =+ M.insert v (S.delete v ds) m+ insDep m _ =+ m++-- | Generate JS AST for bindings.+genAST :: Config -> ModuleName -> [StgBinding] -> [(S.Set J.Name, AST Stm)]+genAST cfg modname binds =+ binds'+ where+ binds' =+ map (depsAndCode . genJS cfg myModName . uncurry (genBind True))+ $ concatMap unRec+ $ binds+ myModName = moduleNameString modname+ depsAndCode (_, ds, locs, stm) = (ds S.\\ locs, stm nullRet)++-- | Generate code for an STG expression.+genEx :: StgExpr -> JSGen Config (AST Exp)+genEx (StgApp f xs) = do+ genApp f xs+genEx (StgLit l) = do+ genLit l+genEx (StgConApp con args) = do+ (tag, stricts) <- genDataCon con+ (args', stricts') <- genArgsPair $ zip args stricts+ -- Don't create unboxed tuples with a single element.+ case (isUnboxedTupleCon con, args') of+ (True, [arg]) -> return $ evaluate arg (head stricts')+ _ -> mkCon tag args' stricts'+ where+ -- Always inline bools+ mkCon l@(AST (Lit (LBool _)) _) _ _ = return l+ mkCon tag as ss = return $ array (tag : zipWith evaluate as ss)+ evaluate arg True = eval arg+ evaluate arg _ = arg+genEx (StgOpApp op args _) = do+ args' <- genArgs args+ cfg <- getCfg+ let theOp = case op of+ StgPrimOp op' ->+ genOp cfg op' args'+ StgPrimCallOp (PrimCall f _) ->+ Right $ callForeign (unpackFS f) args'+ StgFCallOp (CCall (CCallSpec (StaticTarget f _ _) _ _)) _t ->+ Right $ callForeign (unpackFS f) args'+ _ ->+ error $ "Tried to generate unsupported dynamic foreign call!"+ case theOp of+ Right x -> return x+ Left err -> warn Normal err >> return (runtimeError err)+genEx (StgLet bind ex) = do+ genBindRec bind+ genEx ex+genEx (StgLetNoEscape _ _ bind ex) = do+ genBindRec bind+ genEx ex+genEx (StgCase ex _ _ bndr _ t alts) = do+ genCase t ex bndr alts+genEx (StgSCC _ _ _ ex) = do+ genEx ex+genEx (StgTick _ _ ex) = do+ genEx ex+genEx (StgLam _ _) = do+ error "StgLam caught during code generation - that's impossible!"++genBindRec :: StgBinding -> JSGen Config ()+genBindRec bs@(StgRec _) = do+ mapM_ (genBind False (Just len) . snd) bs'+ where+ bs' = unRec bs+ len = length bs'+genBindRec b =+ genBind False Nothing b++-- | Generate code for all bindings. genBind spits out an error if it receives+-- a recursive binding; this is because it's quite a lot easier to keep track+-- of which functions depend on each other if every genBind call results in a+-- single function being generated.+-- Use `genBindRec` to generate code for local potentially recursive bindings +-- as their dependencies get merged into their parent's anyway.+genBind :: Bool -> Maybe Int -> StgBinding -> JSGen Config ()+genBind onTopLevel funsInRecGroup (StgNonRec v rhs) = do+ v' <- genVar v+ pushBind v'+ when (not onTopLevel) $ do+ addLocal v'+ expr <- genRhs (isJust funsInRecGroup) rhs+ popBind+ let expr' = optimizeFun v' expr+ continue $ newVar True v' expr'+genBind _ _ (StgRec _) =+ error $ "genBind got recursive bindings!"++-- | Generate the RHS of a binding.+genRhs :: Bool -> StgRhs -> JSGen Config (AST Exp)+genRhs recursive (StgRhsCon _ con args) = do+ -- 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)+ else genEx (StgConApp con args)+genRhs _ (StgRhsClosure _ _ _ upd _ args body) = do+ args' <- mapM genVar args+ (retExp, body') <- isolate $ do+ mapM_ addLocal args'+ genEx body+ return $ if isUpdatable upd && null args+ then thunk' (body' $ ret retExp)+ else fun args' (body' $ ret retExp)+ where+ thunk' (AST (Return l@(Lit _)) js) = AST l js+ thunk' stm = thunk 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.+unRec :: StgBinding -> [(Maybe Int, StgBinding)]+unRec (StgRec bs) = zip (repeat len) (map (uncurry StgNonRec) bs)+ where+ len = Just $ length bs+unRec b = [(Nothing, b)]++-- | Filter a list of (Var, anything) pairs, generate JSVars from the Vars+-- and then return both lists.+-- Lists of vars are often accompanied by lists of strictness or usage+-- annotations, which need to be filtered for types without representation+-- as well.+genArgVarsPair :: [(Var.Var, a)] -> JSGen Config ([J.Var], [a])+genArgVarsPair vps = do+ vs' <- mapM genVar vs+ return (vs', xs) + where+ (vs, xs) = unzip $ filter (hasRepresentation . fst) vps++genCase :: AltType -> StgExpr -> Id -> [StgAlt] -> JSGen Config (AST Exp)+genCase t ex scrut alts = do+ ex' <- genEx ex+ -- If we have a unary unboxed tuple, we want to eliminate the case+ -- entirely (modulo evaluation), so just generate the expression in the+ -- sole alternative.+ case (isUnaryUnboxedTuple scrut, alts) of+ (True, [(_, as, _, expr)]) | [arg] <- filter hasRepresentation as -> do+ arg' <- genVar arg+ addLocal [arg']+ continue (newVar (reorderableType scrut) arg' ex')+ genEx expr+ (True, _) -> do+ error "Case on unary unboxed tuple with more than one alt! WTF?!"+ _ -> do+ -- Generate scrutinee and result vars+ scrut' <- genVar scrut+ res <- genResultVar scrut+ addLocal [scrut', res]+ -- Split alts into default and general, and generate code for them+ let (defAlt, otherAlts) = splitAlts alts+ scrutinee = cmp (varExp scrut')+ (_, defAlt') <- genAlt scrut' res defAlt+ alts' <- mapM (genAlt scrut' res) otherAlts+ -- Use the ternary operator where possible.+ useSloppyTCE <- sloppyTCE `fmap` getCfg+ self <- if useSloppyTCE then return blackHoleVar else getCurrentBinding+ case tryTernary self scrutinee (varExp res) defAlt' alts' of+ Just ifEx -> do+ continue $ newVar (reorderableType scrut) scrut' ex'+ continue $ newVar True res ifEx+ return (varExp res)+ _ -> do+ continue $ newVar (reorderableType scrut) scrut' ex'+ continue $ case_ scrutinee defAlt' alts'+ return (varExp res)+ where+ getTag s = index s (litN 0)+ cmp = case t of+ PrimAlt _ -> id+ AlgAlt tc -> if tyConIsBoolean tc then id else getTag+ _ -> getTag++ tyConIsBoolean tc =+ case (n, m) of+ ("Bool", "GHC.Types") -> True+ _ -> False+ where+ n = occNameString $ nameOccName $ tyConName tc+ m = moduleNameString $ moduleName $ nameModule $ tyConName tc+++-- | Split a list of StgAlts into (default, [rest]). Since all case expressions+-- are total, if there is no explicit default branch, the last conditional+-- branch is the default one.+splitAlts :: [StgAlt] -> (StgAlt, [StgAlt])+splitAlts alts =+ case partition isDefault alts of+ ([defAlt], otherAlts) -> (defAlt, otherAlts)+ ([], otherAlts) -> (last otherAlts, init otherAlts) + _ -> error "More than one default alt in case!"+ where+ isDefault (DEFAULT, _, _, _) = True+ isDefault _ = False++genAlt :: J.Var -> J.Var -> StgAlt -> JSGen Config (AST Exp,AST Stm -> AST Stm)+genAlt scrut res (con, args, used, body) = do+ construct <- case con of+ -- undefined is intentional here - the first element is never touched.+ DEFAULT -> return (undefined, )+ LitAlt l -> (,) <$> genLit l+ DataAlt c | tag <- genDataConTag c -> return (tag, )+ (args', used') <- genArgVarsPair (zip args used)+ addLocal args'+ let binds = [bindVar v ix | (v, True, ix) <- zip3 args' used' [1..]]+ (_, body') <- isolate $ do+ continue $ foldr (.) id binds+ retEx <- genEx body+ continue $ newVar True res retEx+ return $ construct body'+ where+ bindVar v ix = newVar True v (index (varExp scrut) (litN ix))++-- | Generate a result variable for the given scrutinee variable.+genResultVar :: Var.Var -> JSGen Config J.Var+genResultVar v = (\mn -> toJSVar mn v (Just "#result")) <$> getModName++-- | Generate a new variable and add a dependency on it to the function+-- currently being generated.+genVar :: Var.Var -> JSGen Config J.Var+genVar v | hasRepresentation v = do+ case toBuiltin v of+ Just v' -> return v'+ _ -> do+ mymod <- getModName+ v' <- return $ toJSVar mymod v Nothing+ dependOn v'+ return v'+genVar _ = do+ return $ foreignVar "_"++-- | Extracts the name of a foreign var.+foreignName :: ForeignCall -> String+foreignName (CCall (CCallSpec (StaticTarget str _ _) _ _)) =+ unpackFS str+foreignName _ =+ error "Dynamic foreign calls not supported!"++toJSVar :: String -> Var.Var -> Maybe String -> J.Var+toJSVar thisMod v msuffix =+ case idDetails v of+ FCallId fc -> foreignVar (foreignName fc)+ _+ | isLocalId v && not hasMod ->+ internalVar (name (unique ++ suffix) (Just (myPkg, myMod))) ""+ | isGlobalId v || hasMod ->+ internalVar (name (extern ++ suffix) (Just (myPkg, myMod))) comment+ _ ->+ error $ "Var is not local, global or external!"+ where+ comment = myMod ++ "." ++ extern ++ suffix+ suffix = case msuffix of+ Just s -> s+ _ -> ""+ vname = Var.varName v+ hasMod = case nameModule_maybe vname of+ Nothing -> False+ _ -> True+ myMod =+ maybe thisMod (moduleNameString . moduleName) (nameModule_maybe vname)+ myPkg =+ maybe "main" (showOutputable . modulePackageId) (nameModule_maybe vname)+ extern = occNameString $ nameOccName vname+ unique = show $ nameUnique vname++-- | Generate an argument list. Any arguments of type State# a are filtered out.+genArgs :: [StgArg] -> JSGen Config [AST Exp]+genArgs = mapM genArg . filter hasRep+ where+ hasRep (StgVarArg v) = hasRepresentation v+ hasRep _ = True++-- | Filter out args without representation, along with their accompanying+-- pair element, then generate code for the args.+-- Se `genArgVarsPair` for more information.+genArgsPair :: [(StgArg, a)] -> JSGen Config ([AST Exp], [a])+genArgsPair aps = do+ args' <- mapM genArg args+ return (args', xs)+ where+ (args, xs) = unzip $ filter hasRep aps+ hasRep (StgVarArg v, _) = hasRepresentation v+ hasRep _ = True++-- | Returns True if the given var actually has a representation.+-- Currently, only values of type State# a are considered representationless.+hasRepresentation :: Var.Var -> Bool+hasRepresentation = typeHasRep . varType++typeHasRep :: Type -> Bool+typeHasRep t =+ case splitTyConApp_maybe t of+ Just (tc, _) -> tc /= statePrimTyCon+ _ -> True++genArg :: StgArg -> JSGen Config (AST Exp)+genArg (StgVarArg v) = varExp <$> genVar v+genArg (StgLitArg l) = genLit l++-- | Generate code for data constructor creation. Returns a pair of+-- (constructor, field strictness annotations).+genDataCon :: DataCon -> JSGen Config (AST Exp, [Bool])+genDataCon dc = do+ let tagexp = genDataConTag dc+ tag = astCode tagexp+ case tag of+ (Lit (LBool _)) ->+ return (tagexp, [])+ _ ->+ return (tagexp, map strict (dataConRepStrictness dc))+ where+ strict MarkedStrict = True+ strict _ = False++-- | Generate the tag for a data constructor. This is used both by genDataCon+-- and directly by genCase to generate constructors for matching.+--+-- IMPORTANT: remember to update the RTS if any changes are made to the+-- constructor tag values!+genDataConTag :: DataCon -> AST Exp+genDataConTag d = do+ let n = occNameString $ nameOccName $ dataConName d+ m = moduleNameString $ moduleName $ nameModule $ dataConName d+ case (n, m) of+ ("True", "GHC.Types") -> lit True+ ("False", "GHC.Types") -> lit False+ _ -> lit (fromIntegral $ dataConTag d :: Double)++-- | Generate literals.+genLit :: L.Literal -> JSGen Config (AST Exp)+genLit l = do+ case l of+ MachStr s -> return . lit $ hexifyString s+ MachInt n+ | n > 2147483647 ||+ n < -2147483648 -> do warn Normal (constFail "Int" n)+ return $ truncInt n+ | otherwise -> return . litN $ fromIntegral n+ MachFloat f -> return . litN $ fromRational f+ MachDouble d -> return . litN $ fromRational d+ MachChar c -> return . litN $ fromIntegral $ ord c+ MachWord w+ | w > 0xffffffff -> do warn Normal (constFail "Word" w)+ return $ truncWord w+ | otherwise -> return . litN $ fromIntegral w+ MachWord64 w -> return . litN $ fromIntegral w+ MachNullAddr -> return $ litN 0+ MachInt64 n -> return . litN $ fromIntegral n+ LitInteger n _ -> return . lit $ n+ MachLabel _ _ _ -> return $ lit ":(" -- Labels point to machine code - ignore!+ where+ constFail t n = t ++ " literal " ++ show n ++ " doesn't fit in 32 bits;"+ ++ " truncating!"+ truncInt n = litN . fromIntegral $ (fromIntegral n :: Int32)+ truncWord w = litN . fromIntegral $ (fromIntegral w :: Word32)++-- | Generate a function application.+genApp :: Var.Var -> [StgArg] -> JSGen Config (AST Exp)+genApp f xs = do+ f' <- varExp <$> genVar f+ xs' <- mapM genArg xs+ if null xs+ then return $ eval f'+ else return $ call arity f' xs'+ where+ arity = arityInfo $ idInfo f++-- | Returns True if the given Var is an unboxed tuple with a single element+-- after any represenationless elements are discarded.+isUnaryUnboxedTuple :: Var.Var -> Bool+isUnaryUnboxedTuple v = maybe False id $ do+ (_, args) <- splitTyConApp_maybe t+ case filter typeHasRep args of+ [_] -> return $ isUnboxedTupleType t+ _ -> return False+ where+ t = varType v++-- | Is it safe to reorder values of the given type?+reorderableType :: Var.Var -> Bool+reorderableType v =+ case splitTyConApp_maybe t of+ Just (_, args) -> length (filter typeHasRep args) == length args+ _ -> typeHasRep t+ where+ t = varType v++-- | Generate a JS \xXX or \uXXXX escape sequence for a char if it's >127.+toHex :: Char -> String+toHex c =+ case ord c of+ n | n < 127 -> [c]+ | otherwise -> toHex' (n `rem` 65536)+ where+ toHex' n =+ case toH "" n of+ s@(_:_:[]) -> "\\x" ++ s+ s -> "\\u" ++ s++ toH s 0 = s+ toH s n = case n `quotRem` 16 of+ (next, ch) -> toH (i2h ch : s) next++ i2h n | n < 10 = chr (n + 48)+ | otherwise = chr (n + 87)++-- | Escape all non-ASCII characters in the given string.+hexifyString :: FastString -> String+hexifyString = concatMap toHex . unpackFS
+ src/Haste/Config.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+module Haste.Config (+ Config (..), AppStart, defConfig, stdJSLibs, startASAP,+ startOnLoadComplete, fastMultiply, safeMultiply) where+import Data.JSTarget+import System.IO.Unsafe (unsafePerformIO)+import System.FilePath (replaceExtension)+import Paths_haste_compiler (getDataFileName)+import DynFlags+import Data.ByteString.Lazy.Builder+import Data.Monoid+import Haste.Environment++type AppStart = Builder -> Builder++stdJSLibs :: [FilePath]+stdJSLibs = unsafePerformIO $ mapM getDataFileName [+ "rts.js", "stdlib.js", "MVar.js", "StableName.js", "Integer.js", "md5.js",+ "array.js", "pointers.js"+ ]++-- | Execute the program as soon as it's loaded into memory.+-- Evaluate the result of applying main, as we might get a thunk back if+-- we're doing TCE. This is so cheap, small and non-intrusive we might+-- as well always do it this way, to simplify the config a bit.+startASAP :: AppStart+startASAP mainSym =+ "A(" <> mainSym <> ", [0]);"++-- | Execute the program when the document has finished loading.+startOnLoadComplete :: AppStart+startOnLoadComplete mainSym =+ "window.onload = function() {" <> startASAP mainSym <> "};"++-- | Int op wrapper for strictly 32 bit (|0).+strictly32Bits :: AST Exp -> AST Exp+strictly32Bits = flip (binOp BitOr) (litN 0)++-- | Safe Int multiplication.+safeMultiply :: AST Exp -> AST Exp -> AST Exp+safeMultiply a b = callForeign "imul" [a, b]++-- | Fast but unsafe Int multiplication.+fastMultiply :: AST Exp -> AST Exp -> AST Exp+fastMultiply = binOp Mul++-- | Compiler configuration.+data Config = Config {+ -- | Runtime files to dump into the JS blob.+ rtsLibs :: [FilePath],+ -- | Path to directory where system jsmods are located.+ libPath :: FilePath,+ -- | Write all jsmods to this path.+ targetLibPath :: FilePath,+ -- | A function that takes the main symbol as its input and outputs the+ -- code that starts the program.+ appStart :: AppStart,+ -- | Options to the pretty printer.+ ppOpts :: PPOpts,+ -- | A function that takes the name of the a target as its input and+ -- outputs the name of the file its JS blob should be written to.+ outFile :: String -> String,+ -- | Link the program?+ performLink :: Bool,+ -- | A function to call on each Int arithmetic primop.+ wrapIntMath :: AST Exp -> AST Exp,+ -- | Operation to use for Int multiplication.+ multiplyIntOp :: AST Exp -> AST Exp -> AST Exp,+ -- | Be verbose about warnings, etc.?+ verbose :: Bool,+ -- | Perform optimizations over the whole program at link time?+ wholeProgramOpts :: Bool,+ -- | Allow the possibility that some tail recursion may not be optimized+ -- in order to gain slightly smaller code?+ sloppyTCE :: Bool,+ -- | Run the entire thing through Google Closure when done?+ useGoogleClosure :: Maybe FilePath,+ -- | Any external Javascript to link into the JS bundle.+ jsExternals :: [FilePath],+ -- | Dynamic flags used for compilation.+ dynFlags :: DynFlags+ }++-- | Default compiler configuration.+defConfig :: Config+defConfig = Config {+ rtsLibs = stdJSLibs,+ libPath = jsmodDir,+ targetLibPath = ".",+ appStart = startOnLoadComplete,+ ppOpts = def,+ outFile = flip replaceExtension "js",+ performLink = True,+ wrapIntMath = strictly32Bits,+ multiplyIntOp = safeMultiply,+ verbose = False,+ wholeProgramOpts = False,+ sloppyTCE = False,+ useGoogleClosure = Nothing,+ jsExternals = [],+ dynFlags = tracingDynFlags+ }
+ src/Haste/Environment.hs view
@@ -0,0 +1,76 @@+-- | Paths, host bitness and other environmental information about Haste.+module Haste.Environment where+import System.Process+import System.IO.Unsafe+import System.Directory+import System.FilePath+import Data.Bits (bitSize)+import Foreign.C.Types (CIntPtr)++-- | Host word size in bits.+hostWordSize :: Int+hostWordSize = bitSize (undefined :: CIntPtr)++-- | Directory where cabal resides. Bundled JS files end up here.+cabalDir :: FilePath+cabalDir = unsafePerformIO $ getAppUserDataDirectory "cabal"++-- | Cabal dir for binaries.+cabalBinDir :: FilePath+cabalBinDir = cabalDir </> "bin"++-- | Directory housing hi files, jsmods and other stuff Haste spits out.+hasteDir :: FilePath+hasteDir = unsafePerformIO $ getAppUserDataDirectory "haste"++jsmodDir :: FilePath+jsmodDir = hasteDir </> "lib"++-- | Directory containing library information. +pkgLibDir :: FilePath+pkgLibDir = hasteInstDir </> "lib"++-- | Base directory for haste-inst.+hasteInstDir :: FilePath+hasteInstDir = hasteDir </> "haste-install"++-- | Directory housing package information.+pkgDir :: FilePath+pkgDir = hasteDir </> "haste-pkg"++-- | Run a process and wait for its completion.+runAndWait :: FilePath -> [String] -> Maybe FilePath -> IO ()+runAndWait file args workDir = do+ h <- runProcess file args workDir Nothing Nothing Nothing Nothing+ _ <- waitForProcess h+ return ()++-- | Find an executable.+locateBinary :: String -> [FilePath] -> IO (Either String FilePath)+locateBinary progname (c:cs) = do+ mexe <- findExecutable c+ case mexe of+ Nothing -> locateBinary progname cs+ Just exe -> return (Right exe)+locateBinary progname _ = do+ return $ Left $ "No " ++ progname ++ " executable found; aborting!"++-- | Find a binary that's probably in Cabal's bin directory.+binaryPath :: FilePath -> FilePath+binaryPath exe = unsafePerformIO $ do+ b <- locateBinary exe [exe, cabalBinDir </> exe]+ case b of+ Left err -> error err+ Right path -> return path++-- | The main Haste compiler binary.+hasteBinary :: FilePath+hasteBinary = binaryPath "hastec"++-- | Binary for haste-pkg.+hastePkgBinary :: FilePath+hastePkgBinary = binaryPath "haste-pkg"++-- | JAR for Closure compiler.+closureCompiler :: FilePath+closureCompiler = hasteDir </> "compiler.jar"
+ src/Haste/Errors.hs view
@@ -0,0 +1,22 @@+-- | Functions for warning about and causing runtime errors.+module Haste.Errors (runtimeError, warn, WarnLevel(..)) where+import System.IO.Unsafe+import System.IO+import Data.JSTarget+import Haste.Monad+import Haste.Config++data WarnLevel = Normal | Verbose deriving Eq++-- | Produce a runtime error whenever this expression gets evaluated.+runtimeError :: String -> AST Exp+runtimeError s = callForeign "die" [lit s]++-- | Produce a warning message. This function is horrible and should be+-- replaced with some proper handling for warnings.+warn :: WarnLevel -> String -> JSGen Config ()+warn wlvl msg = do+ vrb <- verbose `fmap` getCfg+ if wlvl == Normal || vrb+ then return $! unsafePerformIO $ hPutStrLn stderr $ "WARNING: " ++ msg+ else return ()
+ src/Haste/Linker.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module Haste.Linker (link) where+import Haste.Config+import Haste.Module+import qualified Data.Map as M+import qualified Data.Set as S+import Control.Monad.State.Strict+import Control.Applicative+import Data.JSTarget+import qualified Data.ByteString.Lazy as B+import Data.ByteString.Lazy.Builder+import Data.Monoid++-- | The program entry point.+-- This will need to change when we start supporting building "binaries"+-- using cabal, since we'll have all sorts of funny package names then.+mainSym :: Name+mainSym = name "main" (Just ("main", "Main"))++-- | Link a program using the given config and input file name.+link :: Config -> String -> FilePath -> IO ()+link cfg pkgid target = do+ ds <- getAllDefs (libPath cfg) pkgid mainSym+ let myDefs = if wholeProgramOpts cfg then topLevelInline ds else ds+ let (progText, mainSym') = prettyProg (ppOpts cfg) mainSym myDefs+ callMain = appStart cfg mainSym'+ + rtslibs <- mapM readFile $ rtsLibs cfg ++ jsExternals cfg+ B.writeFile (outFile cfg target)+ $ toLazyByteString + $ stringUtf8 (unlines rtslibs)+ <> progText+ <> callMain++-- | Generate a sequence of all assignments needed to run Main.main.+getAllDefs :: FilePath -> String -> Name -> IO (AST Stm)+getAllDefs libpath pkgid mainsym =+ runDep $ addDef libpath pkgid mainsym++data DepState = DepState {+ defs :: !(AST Stm -> AST Stm),+ alreadySeen :: !(S.Set Name),+ modules :: !(M.Map String Module)+ }++newtype DepM a = DepM (StateT DepState IO a)+ deriving (Monad, MonadIO)++initState :: DepState+initState = DepState {+ defs = id,+ alreadySeen = S.empty,+ modules = M.empty+ }++-- | Run a dependency resolution computation.+runDep :: DepM a -> IO (AST Stm)+runDep (DepM m) = do+ defs' <- defs . snd <$> runStateT m initState+ return (defs' nullRet)++instance MonadState DepState DepM where+ get = DepM $ get+ put = DepM . put++-- | Return the module the given variable resides in.+getModuleOf :: FilePath -> Name -> DepM Module+getModuleOf libpath v =+ case moduleOf v of+ Just "GHC.Prim" -> return foreignModule+ Just "" -> return foreignModule+ Just m -> getModule libpath (maybe "main" id $ pkgOf v) m+ _ -> return foreignModule++-- | Return the module at the given path, loading it into cache if it's not+-- already there.+getModule :: FilePath -> String -> String -> DepM Module+getModule libpath pkgid modname = do+ st <- get+ case M.lookup modname (modules st) of+ Just m ->+ return m+ _ -> do+ liftIO $ putStrLn $ "Linking " ++ modname+ m <- liftIO $ readModule libpath pkgid modname+ put st {modules = M.insert modname m (modules st)}+ return m++-- | Add a new definition and its dependencies. If the given identifier has+-- already been added, it's just ignored.+addDef :: FilePath -> String -> Name -> DepM ()+addDef libpath pkgid v = do+ st <- get+ when (not $ v `S.member` alreadySeen st) $ do+ m <- getModuleOf libpath v++ -- getModuleOf may update the state, so we need to refresh it+ st' <- get+ let dependencies = maybe S.empty id (M.lookup v (modDeps m))+ put st' {alreadySeen = S.insert v (alreadySeen st')}+ S.foldl' (\a x -> a >> addDef libpath pkgid x) (return ()) dependencies++ -- addDef _definitely_ updates the state, so refresh once again+ st'' <- get+ let Name comment _ = v+ defs' =+ maybe (defs st'')+ (\body -> defs st'' . newVar True (internalVar v comment) body)+ (M.lookup v (modDefs m))+ put st'' {defs = defs'}
+ src/Haste/Module.hs view
@@ -0,0 +1,54 @@+-- | Read and write JSMods.+module Haste.Module (writeModule, readModule, readModuleFingerprint) where+import Module (moduleNameSlashes, mkModuleName)+import qualified Data.ByteString.Lazy as B+import System.FilePath+import System.Directory+import System.IO+import Control.Applicative+import Data.JSTarget+import Data.Binary++-- | The file extension to use for modules.+jsmodExt :: String+jsmodExt = "jsmod"++moduleFilePath :: FilePath -> String -> String -> FilePath+moduleFilePath basepath pkgid modname =+ flip addExtension jsmodExt $+ basepath </> pkgid </> (moduleNameSlashes $ mkModuleName modname)++readModuleFingerprint :: FilePath -> String -> String -> IO Fingerprint+readModuleFingerprint basepath pkgid modname = do+ x <- doesFileExist path+ let path' = if x then path else syspath + withFile path' ReadMode $ \h -> do+ fp <- decode <$> B.hGetContents h+ return $! fp+ where+ path = moduleFilePath "" "" modname+ syspath = moduleFilePath basepath pkgid modname++-- | Write a module to file, with the extension specified in `fileExt`.+-- Assuming that fileExt = "jsmod", a module Foo.Bar is written to+-- basepath/Foo/Bar.jsmod+-- If any directory in the path where the module is to be written doesn't+-- exist, it gets created.+writeModule :: FilePath -> Module -> IO ()+writeModule basepath m@(Module _ pkgid modname _ _) = do+ createDirectoryIfMissing True (takeDirectory path)+ B.writeFile path (encode m)+ where+ path = moduleFilePath basepath pkgid modname++-- | Read a module from file. If the module is not found at the specified path,+-- libpath/path is tried instead. Panics if the module is found on neither+-- path.+readModule :: FilePath -> String -> String -> IO Module+readModule basepath pkgid modname = do+ x <- doesFileExist path+ let path' = if x then path else syspath + decode <$> B.readFile path'+ where+ path = moduleFilePath "." pkgid modname+ syspath = moduleFilePath basepath pkgid modname
+ src/Haste/Monad.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}+module Haste.Monad (+ JSGen, genJS, dependOn, getModName, addLocal, getCfg, continue, isolate,+ pushBind, popBind, getCurrentBinding+ ) where+import Control.Monad.State+import Data.JSTarget as J hiding (modName)+import qualified Data.Set as S+import Control.Applicative++data GenState cfg = GenState {+ deps :: !(S.Set Name),+ locals :: !(S.Set Name),+ continuation :: !(AST Stm -> AST Stm),+ bindStack :: [Var],+ modName :: String,+ config :: cfg+ }++initialState :: GenState cfg+initialState = GenState {+ deps = S.empty,+ locals = S.empty,+ continuation = id,+ bindStack = [],+ modName = undefined,+ config = undefined+ }++newtype JSGen cfg a =+ JSGen (State (GenState cfg) a)+ deriving (Monad, Functor, Applicative)++class Dependency a where+ -- | Add a dependency to the function currently being generated.+ dependOn :: a -> JSGen cfg ()+ -- | Mark a symbol as local, excluding it from the dependency graph.+ addLocal :: a -> JSGen cfg ()++instance Dependency J.Name where+ dependOn v = JSGen $ do+ st <- get+ put st {deps = S.insert v (deps st)}++ addLocal v = JSGen $ do+ st <- get+ put st {locals = S.insert v (locals st)}++instance Dependency J.Var where+ dependOn (Foreign _) = return ()+ dependOn (Internal n _) = dependOn n+ addLocal (Foreign _) = return ()+ addLocal (Internal n _) = addLocal n++instance Dependency a => Dependency [a] where+ dependOn = mapM_ dependOn+ addLocal = mapM_ addLocal++instance Dependency a => Dependency (S.Set a) where+ dependOn = dependOn . S.toList+ addLocal = addLocal . S.toList++genJS :: cfg -- ^ Config to use for code generation.+ -> String -- ^ Name of the module being compiled.+ -> JSGen cfg a -- ^ The code generation computation.+ -> (a, S.Set J.Name, S.Set J.Name, AST Stm -> AST Stm)+genJS cfg myModName (JSGen gen) =+ case runState gen initialState {modName = myModName, config = cfg} of+ (a, GenState dependencies loc cont _ _ _) ->+ (a, dependencies, loc, cont)++getModName :: JSGen cfg String+getModName = JSGen $ modName <$> get++pushBind :: Var -> JSGen cfg ()+pushBind v = JSGen $ do+ st <- get+ put st {bindStack = v : bindStack st}++popBind :: JSGen cfg ()+popBind = JSGen $ do+ st <- get+ put st {bindStack = tail $ bindStack st}++getCurrentBinding :: JSGen cfg Var+getCurrentBinding = JSGen $ fmap (head . bindStack) get++-- | Add a new continuation onto the current one.+continue :: (AST Stm -> AST Stm) -> JSGen cfg ()+continue cont = JSGen $ do+ st <- get+ put st {continuation = continuation st . cont}++-- | Run a GenJS computation in isolation, returning its results rather than+-- writing them to the output stream. Dependencies and locals are still+-- updated, however.+isolate :: JSGen cfg a -> JSGen cfg (a, AST Stm -> AST Stm)+isolate gen = do+ myMod <- getModName+ cfg <- getCfg+ b <- getCurrentBinding+ let (x, dep, loc, cont) = genJS cfg myMod (pushBind b >> gen)+ dependOn dep+ addLocal loc+ return (x, cont)++getCfg :: JSGen cfg cfg+getCfg = JSGen $ fmap config get
+ src/Haste/PrimOps.hs view
@@ -0,0 +1,320 @@+module Haste.PrimOps (genOp) where+import Prelude hiding (LT, GT)+import PrimOp+import Data.JSTarget+import Haste.Config+import Haste.Util++-- | Dummy State# RealWorld value for where one is needed.+defState :: AST Exp+defState = litN 0++-- | Generate primops.+-- Many of these ops return lifted Bool values; however, no thunk is+-- generated for them in order to conserve space and CPU time. This relies+-- on the evaluation operation in the RTS being able to handle plain values+-- as though they were thunks. If this were to change, all those ops MUST+-- be changed to return thunks!+genOp :: Config -> PrimOp -> [AST Exp] -> Either String (AST Exp)+genOp cfg op xs =+ case op of+ -- negations+ IntNegOp -> Right $ binOp Sub (litN 0) (head xs)+ DoubleNegOp -> Right $ binOp Sub (litN 0) (head xs)+ FloatNegOp -> Right $ binOp Sub (litN 0) (head xs)+ NotOp -> Right $ not_ (head xs) -- bitwise++ -- Conversions+ ChrOp -> Right $ head xs+ OrdOp -> Right $ head xs+ Word2IntOp -> Right $ binOp BitAnd (head xs) (litN 0xffffffff)+ Int2WordOp -> Right $ binOp ShrL (head xs) (litN 0)+ Int2FloatOp -> Right $ head xs+ Int2DoubleOp -> Right $ head xs+ Double2IntOp -> Right $ binOp (BitAnd) (head xs) (litN 0xffffffff)+ Double2FloatOp -> Right $ head xs+ Float2IntOp -> Right $ binOp (BitAnd) (head xs) (litN 0xffffffff)+ Float2DoubleOp -> Right $ head xs+ + -- Narrowing ops+ Narrow8IntOp -> Right $ binOp BitAnd (head xs) (lit (0xff :: Double))+ Narrow16IntOp -> Right $ binOp BitAnd (head xs) (lit (0xffff :: Double))+ Narrow32IntOp -> Right $ binOp BitAnd (head xs) (lit (0xffffffff :: Double))+ Narrow8WordOp -> Right $ binOp BitAnd (head xs) (lit (0xff :: Double))+ Narrow16WordOp -> Right $ binOp BitAnd (head xs) (lit (0xffff :: Double))+ Narrow32WordOp -> Right $ binOp ShrL (binOp BitAnd (head xs) (lit (0xffffffff :: Double))) (litN 0)++ -- Char ops+ CharGtOp -> bOp GT+ CharGeOp -> bOp GTE+ CharEqOp -> bOp Eq+ CharNeOp -> bOp Neq+ CharLtOp -> bOp LT+ CharLeOp -> bOp LTE++ -- Int ops+ IntAddOp -> intMath $ bOp Add+ IntSubOp -> intMath $ bOp Sub+ IntMulOp -> intMath $ Right $ multiplyIntOp cfg (xs !! 0) (xs !! 1)+ -- FIXME: this is correct but slow!+ IntMulMayOfloOp -> intMath $ Right $ multiplyIntOp cfg (xs !! 0) (xs !! 1)+ IntQuotOp -> callF "quot"+ IntQuotRemOp -> callF "quotRemI"+ IntRemOp -> bOp Mod -- JS % operator is actually rem, not mod!+ IntAddCOp -> callF "addC"+ IntSubCOp -> callF "subC"+ ISllOp -> bOp Shl+ ISraOp -> bOp ShrA+ ISrlOp -> bOp ShrL+ IntGtOp -> bOp GT+ IntGeOp -> bOp GTE+ IntLtOp -> bOp LT+ IntLeOp -> bOp LTE+ IntEqOp -> bOp Eq+ IntNeOp -> bOp Neq++ -- Word ops+ WordAddOp -> wordMath $ bOp Add+ WordSubOp -> wordMath $ bOp Sub+ WordMulOp -> wordMath $ callF "imul"+ WordQuotOp -> callF "quot"+ WordQuotRemOp -> callF "quotRemI"+ WordRemOp -> bOp Mod+ AndOp -> wordMath $ bOp BitAnd+ OrOp -> wordMath $ bOp BitOr+ XorOp -> wordMath $ bOp BitXor+ SllOp -> wordMath $ bOp Shl+ SrlOp -> bOp ShrL+ WordGtOp -> bOp GT+ WordGeOp -> bOp GTE+ WordEqOp -> bOp Eq+ WordNeOp -> bOp Neq+ WordLtOp -> bOp LT+ WordLeOp -> bOp LTE++ -- Double ops+ DoubleExpOp -> Right $ callForeign "Math.exp" xs+ DoubleLogOp -> Right $ callForeign "Math.log" xs+ DoubleSqrtOp -> Right $ callForeign "Math.sqrt" xs+ DoubleCosOp -> Right $ callForeign "Math.cos" xs+ DoubleSinOp -> Right $ callForeign "Math.sin" xs+ DoubleTanOp -> Right $ callForeign "Math.tan" xs+ DoubleAcosOp -> Right $ callForeign "Math.acos" xs+ DoubleAsinOp -> Right $ callForeign "Math.asin" xs+ DoubleAtanOp -> Right $ callForeign "Math.atan" xs+ DoubleCoshOp -> Right $ callForeign "cosh" xs+ DoubleSinhOp -> Right $ callForeign "sinh" xs+ DoubleTanhOp -> Right $ callForeign "tanh" xs+ DoubleDecode_2IntOp -> Right $ callForeign "decodeDouble" xs+ DoubleGtOp -> bOp GT+ DoubleGeOp -> bOp GTE+ DoubleEqOp -> bOp Eq+ DoubleNeOp -> bOp Neq+ DoubleLtOp -> bOp LT+ DoubleLeOp -> bOp LTE+ DoubleAddOp -> bOp Add+ DoubleSubOp -> bOp Sub+ DoubleMulOp -> bOp Mul+ DoubleDivOp -> bOp Div+ DoublePowerOp -> callF "Math.pow"++ -- Float ops+ FloatExpOp -> Right $ callForeign "Math.exp" xs+ FloatLogOp -> Right $ callForeign "Math.log" xs+ FloatSqrtOp -> Right $ callForeign "Math.sqrt" xs+ FloatCosOp -> Right $ callForeign "Math.cos" xs+ FloatSinOp -> Right $ callForeign "Math.sin" xs+ FloatTanOp -> Right $ callForeign "Math.tan" xs+ FloatAcosOp -> Right $ callForeign "Math.acos" xs+ FloatAsinOp -> Right $ callForeign "Math.asin" xs+ FloatAtanOp -> Right $ callForeign "Math.atan" xs+ FloatCoshOp -> Right $ callForeign "cosh" xs+ FloatSinhOp -> Right $ callForeign "sinh" xs+ FloatTanhOp -> Right $ callForeign "tanh" xs+ FloatDecode_IntOp -> Right $ callForeign "decodeFloat" xs+ FloatGtOp -> bOp GT+ FloatGeOp -> bOp GTE+ FloatEqOp -> bOp Eq+ FloatNeOp -> bOp Neq+ FloatLtOp -> bOp LT+ FloatLeOp -> bOp LTE+ FloatAddOp -> bOp Add+ FloatSubOp -> bOp Sub+ FloatMulOp -> bOp Mul+ FloatDivOp -> bOp Div+ FloatPowerOp -> callF "Math.pow"+ + -- Array ops+ NewArrayOp -> callF "newArr"+ SameMutableArrayOp -> fmap (thunk . ret) $ bOp Eq+ ReadArrayOp -> Right $ index arr ix+ WriteArrayOp -> Right $ assignEx (index arr ix) rhs+ where (_arr:_ix:rhs:_) = xs+ SizeofArrayOp -> Right $ index (head xs) (lit "length")+ SizeofMutableArrayOp -> Right $ index (head xs) (lit "length")+ IndexArrayOp -> Right $ index arr ix+ UnsafeFreezeArrayOp -> Right $ head xs+ UnsafeThawArrayOp -> Right $ head xs+ -- TODO: copy, clone, freeze, thaw+ + -- Byte Array ops+ NewByteArrayOp_Char -> callF "newByteArr"+ NewPinnedByteArrayOp_Char-> callF "newByteArr"+ SameMutableByteArrayOp -> fmap (thunk . ret) $ bOp Eq+ IndexByteArrayOp_Char -> readArr xs "i8"+ IndexByteArrayOp_Int -> readArr xs "i32"+ IndexByteArrayOp_Int8 -> readArr xs "i8"+ IndexByteArrayOp_Int16 -> readArr xs "i16"+ IndexByteArrayOp_Int32 -> readArr xs "i32"+ IndexByteArrayOp_Word -> readArr xs "w32"+ IndexByteArrayOp_Word8 -> readArr xs "w8"+ IndexByteArrayOp_Word16 -> readArr xs "w16"+ IndexByteArrayOp_Word32 -> readArr xs "w32"+ IndexByteArrayOp_WideChar-> readArr xs "w32"+ IndexByteArrayOp_Float -> readArr xs "f32"+ IndexByteArrayOp_Double -> readArr xs "f64"+ + ReadByteArrayOp_Char -> readArr xs "i8"+ ReadByteArrayOp_Int -> readArr xs "i32"+ ReadByteArrayOp_Int8 -> readArr xs "i8"+ ReadByteArrayOp_Int16 -> readArr xs "i16"+ ReadByteArrayOp_Int32 -> readArr xs "i32"+ ReadByteArrayOp_Word -> readArr xs "w32"+ ReadByteArrayOp_Word8 -> readArr xs "w8"+ ReadByteArrayOp_Word16 -> readArr xs "w16"+ ReadByteArrayOp_Word32 -> readArr xs "w32"+ ReadByteArrayOp_WideChar -> readArr xs "w32"+ ReadByteArrayOp_Float -> readArr xs "f32"+ ReadByteArrayOp_Double -> readArr xs "f64"+ + WriteByteArrayOp_Char -> writeArr xs "i8"+ WriteByteArrayOp_Int -> writeArr xs "i32"+ WriteByteArrayOp_Int8 -> writeArr xs "i8"+ WriteByteArrayOp_Int16 -> writeArr xs "i16"+ WriteByteArrayOp_Int32 -> writeArr xs "i32"+ WriteByteArrayOp_Word -> writeArr xs "w32"+ WriteByteArrayOp_Word8 -> writeArr xs "w8"+ WriteByteArrayOp_Word16 -> writeArr xs "w16"+ WriteByteArrayOp_Word32 -> writeArr xs "w32"+ WriteByteArrayOp_WideChar-> writeArr xs "w32"+ WriteByteArrayOp_Float -> writeArr xs "f32"+ WriteByteArrayOp_Double -> writeArr xs "f64"+ + SizeofByteArrayOp -> Right $ index (head xs) (lit "byteLength")+ SizeofMutableByteArrayOp -> Right $ index (head xs) (lit "byteLength")+ NewAlignedPinnedByteArrayOp_Char -> Right $ callForeign "newByteArr" [xs!!0]+ UnsafeFreezeByteArrayOp -> Right $ head xs+ ByteArrayContents_Char -> Right $ head xs+ + -- Mutable variables+ NewMutVarOp -> callF "nMV"+ ReadMutVarOp -> callF "rMV"+ WriteMutVarOp -> callF "wMV"+ + -- Pointer ops+ WriteOffAddrOp_Char -> writeOffAddr xs "i8" 1+ WriteOffAddrOp_Int -> writeOffAddr xs "i32" 4+ WriteOffAddrOp_Int8 -> writeOffAddr xs "i8" 1+ WriteOffAddrOp_Int16 -> writeOffAddr xs "i16" 2+ WriteOffAddrOp_Int32 -> writeOffAddr xs "i32" 4+ WriteOffAddrOp_Word -> writeOffAddr xs "w32" 4+ WriteOffAddrOp_Word8 -> writeOffAddr xs "w8" 1+ WriteOffAddrOp_Word16 -> writeOffAddr xs "w16" 2+ WriteOffAddrOp_Word32 -> writeOffAddr xs "w32" 4+ WriteOffAddrOp_WideChar-> writeOffAddr xs "w32" 4+ WriteOffAddrOp_Float -> writeOffAddr xs "f32" 4+ WriteOffAddrOp_Double -> writeOffAddr xs "f64" 8+ ReadOffAddrOp_Char -> readOffAddr xs "i8" 1+ ReadOffAddrOp_Int -> readOffAddr xs "i32" 4+ ReadOffAddrOp_Int8 -> readOffAddr xs "i8" 1+ ReadOffAddrOp_Int16 -> readOffAddr xs "i16" 2+ ReadOffAddrOp_Int32 -> readOffAddr xs "i32" 4+ ReadOffAddrOp_Word -> readOffAddr xs "w32" 4+ ReadOffAddrOp_Word8 -> readOffAddr xs "w8" 1+ ReadOffAddrOp_Word16 -> readOffAddr xs "w16" 2+ ReadOffAddrOp_Word32 -> readOffAddr xs "w32" 4+ ReadOffAddrOp_WideChar -> readOffAddr xs "w32" 4+ ReadOffAddrOp_Float -> readOffAddr xs "f32" 4+ ReadOffAddrOp_Double -> readOffAddr xs "f64" 8+ AddrAddOp -> callF "plusAddr"+ AddrSubOp ->+ Right $ callForeign "plusAddr" [addr, binOp Sub (litN 0) off]+ where (addr:off:_) = xs+ AddrEqOp -> callF "addrEq"+ AddrNeOp ->+ Right $ binOp Sub (litN 0) $ callForeign "addrEq" [a, b]+ where (a:b:_) = xs+ AddrLtOp -> callF "addrLT"+ AddrGtOp -> callF "addrGT"+ AddrLeOp ->+ Right $ binOp Sub (litN 0) $ callForeign "addrGT" [a, b]+ where (a:b:_) = xs+ AddrGeOp ->+ Right $ binOp Sub (litN 0) $ callForeign "addrLT" [a, b]+ where (a:b:_) = xs++ -- MVars+ NewMVarOp -> callF "newMVar"+ TakeMVarOp -> callF "takeMVar"+ TryTakeMVarOp -> callF "tryTakeMVar"+ PutMVarOp -> callF "putMVar"+ TryPutMVarOp -> callF "tryPutMVar"+ SameMVarOp -> callF "sameMVar"+ IsEmptyMVarOp -> callF "isEmptyMVar"++ -- Stable names+ MakeStableNameOp -> callF "makeStableName"+ EqStableNameOp -> callF "eqStableName"+ StableNameToIntOp -> Right $ head xs++ -- Exception masking+ -- There's only one thread anyway, so async exceptions can't happen.+ MaskAsyncExceptionsOp -> Right $ callSaturated (head xs) []+ UnmaskAsyncExceptionsOp -> Right $ callSaturated (head xs) []+ MaskStatus -> Right $ litN 0++ -- Misc. ops+ SeqOp -> Right $ callForeign "E" [head xs]+ AtomicallyOp -> Right $ callSaturated (xs !! 0) []+ -- Get the data constructor tag from a value.+ DataToTagOp -> callF "dataToTag"+ TouchOp -> Right $ defState+ RaiseOp -> callF "die"+ RaiseIOOp -> callF "die"+ -- noDuplicate is only relevant in a threaded environment.+ NoDuplicateOp -> Right $ defState+ CatchOp -> callF "jsCatch"+ x -> Left $ "Unsupported PrimOp: " ++ showOutputable x+ where+ (arr:ix:_) = xs+ + writeArr (a:i:rhs:_) elemtype =+ Right $ assignEx (index (index (index a (lit "v")) (lit elemtype)) i) rhs+ writeArr _ _ =+ error "writeArray primop with too few arguments!"++ readArr (a:i:_) elemtype =+ Right $ index (index (index a (lit "v")) (lit elemtype)) i+ readArr _ _ =+ error "writeArray primop with too few arguments!"++ writeOffAddr (addr:off:rhs:_) etype esize =+ Right $ callForeign "writeOffAddr" [lit etype, litN esize, addr, off, rhs]+ writeOffAddr _ _ _ =+ error "writeOffAddr primop with too few arguments!"+ + readOffAddr (addr:off:_) etype esize =+ Right $ callForeign "readOffAddr" [lit etype, litN esize, addr, off]+ readOffAddr _ _ _ =+ error "readOffAddr primop with too few arguments!"++ callF f = Right $ callForeign f xs+ + bOp bop =+ case xs of+ [x, y] -> Right $ binOp bop x y+ _ -> error $ "PrimOps.binOp failed! op is " ++ show bop+ + -- Bitwise ops on words need to be unsigned; exploit the fact that >>> is!+ wordMath = fmap (\oper -> binOp ShrL oper (litN 0))+ intMath = fmap (wrapIntMath cfg)
+ src/Haste/Util.hs view
@@ -0,0 +1,8 @@+-- | Misc. utility functions.+module Haste.Util where+import DynFlags+import Outputable++showOutputable :: Outputable a => a -> String+showOutputable = showPpr tracingDynFlags+
+ src/Haste/Version.hs view
@@ -0,0 +1,42 @@+-- | Contains version information for Haste.+module Haste.Version (hasteVersion, ghcVersion, bootVersion, needsReboot,+ BootVer (..), bootFile) where+import System.IO.Unsafe+import System.Directory+import System.FilePath ((</>))+import System.IO+import Data.Version+import Config (cProjectVersion)+import Haste.Environment (hasteDir)++hasteVersion :: Version+hasteVersion = Version [0, 2] []++ghcVersion :: String+ghcVersion = cProjectVersion++bootVersion :: BootVer+bootVersion = BootVer hasteVersion ghcVersion++bootFile :: FilePath+bootFile = hasteDir </> "booted"++data BootVer = BootVer Version String deriving (Read, Show)++-- | Returns which parts of Haste need rebooting. A change in the boot file+-- format triggers a full reboot.+needsReboot :: Bool+needsReboot = unsafePerformIO $ do+ exists <- doesFileExist bootFile+ if exists+ then do+ fh <- openFile bootFile ReadMode+ bootedVerString <- hGetLine fh+ hClose fh+ case reads bootedVerString of+ [(BootVer hasteVer ghcVer, _)] ->+ return $ hasteVer /= hasteVersion || ghcVer /= ghcVersion+ _ ->+ return True+ else+ return True
+ src/Main.hs view
@@ -0,0 +1,241 @@+module Main (main) where+import GHC+import GHC.Paths (libdir)+import HscMain+import Outputable (showPpr)+import DynFlags hiding (flags)+import TidyPgm+import CorePrep+import CoreToStg+import StgSyn (StgBinding)+import HscTypes+import Module (moduleNameSlashes)+import GhcMonad+import System.Environment (getArgs)+import Control.Monad (when)+import Haste+import Haste.Util (showOutputable)+import Haste.Environment+import Haste.Version+import Args+import ArgSpecs+import System.FilePath (addExtension)+import System.IO+import System.Process (runProcess, waitForProcess, rawSystem)+import System.Exit (ExitCode (..), exitFailure)+import System.Directory (renameFile)+import Filesystem (getModified, isFile)+import Data.Version+import Data.List+import Data.String+import qualified Data.ByteString.Char8 as B++logStr :: String -> IO ()+logStr = hPutStrLn stderr++rebootMsg :: String+rebootMsg = "Haste needs to be rebooted; please run haste-boot"++printInfo :: IO ()+printInfo = do+ ghc <- runGhc (Just libdir) getSessionDynFlags+ putStrLn $ formatInfo $ compilerInfo ghc+ where+ formatInfo = ('[' :) . tail . unlines . (++ ["]"]) . map ((',' :) . show)++-- | Check for arguments concerning version info and the like, and act on them.+-- Return True if the compiler should run afterwards.+preArgs :: [String] -> IO Bool+preArgs args+ | "--numeric-version" `elem` args =+ putStrLn ghcVersion >> return False+ | "--info" `elem` args =+ printInfo >> return False+ | "--version" `elem` args =+ putStrLn (showVersion hasteVersion) >> return False+ | "--supported-extensions" `elem` args =+ (putStrLn $ unlines $ supportedLanguagesAndExtensions) >> return False+ | "--supported-languages" `elem` args =+ (putStrLn $ unlines $ supportedLanguagesAndExtensions) >> return False+ | otherwise =+ return True++main :: IO ()+main = do+ args <- fmap (++ packageDBArgs) getArgs+ runCompiler <- preArgs args+ when (runCompiler) $ do+ if allSupported args+ then hasteMain args+ else callVanillaGHC args+ where+ packageDBArgs = ["-no-global-package-db",+ "-no-user-package-db",+ "-package-db " ++ pkgDir]++-- | Call vanilla GHC; used for boot files and the like.+callVanillaGHC :: [String] -> IO ()+callVanillaGHC args = do+ _ <- rawSystem "ghc" (filter noHasteArgs args)+ return ()+ where+ noHasteArgs x =+ x /= "--libinstall" &&+ x /= "--unbooted"++-- | Run the compiler if everything's satisfactorily booted, otherwise whine+-- and exit.+hasteMain :: [String] -> IO ()+hasteMain args+ | not needsReboot =+ compiler ("-O2" : args)+ | otherwise = do+ if "--unbooted" `elem` args+ then compiler (filter (/= "--unbooted") ("-O2" : args))+ else fail rebootMsg++-- | Determine whether all given args are handled by Haste, or if we need to+-- ship them off to vanilla GHC instead.+allSupported :: [String] -> Bool+allSupported args =+ and args'+ where+ args' = [not $ any (`isSuffixOf` a) someoneElsesProblems | a <- args]+ someoneElsesProblems = [".c", ".cmm", ".hs-boot", ".lhs-boot"]++-- | The main compiler driver.+compiler :: [String] -> IO ()+compiler cmdargs = do+ let cmdargs' | "--opt-all" `elem` cmdargs = "-O2" : cmdargs+ | "--opt-all-unsafe" `elem` cmdargs = "-O2" : cmdargs+ | otherwise = cmdargs+ argRes = handleArgs defConfig argSpecs cmdargs'+ usedGhcMode = if "-c" `elem` cmdargs then OneShot else CompManager++ case argRes of+ -- We got --help as an argument - display help and exit.+ Left help -> putStrLn help+ + -- We got a config and a set of arguments for GHC; let's compile!+ Right (cfg, ghcargs) -> do+ -- Parse static flags, but ignore profiling.+ (ghcargs', _) <- parseStaticFlags [noLoc a | a <- ghcargs, a /= "-prof"]+ + runGhc (Just libdir) $ handleSourceError (const $ liftIO exitFailure) $ do+ -- Handle dynamic GHC flags. Make sure __HASTE__ is #defined.+ let args = "-D__HASTE__" : map unLoc ghcargs'+ dynflags <- getSessionDynFlags+ (dynflags', files, _) <- parseDynamicFlags dynflags (map noLoc args)+ _ <- setSessionDynFlags dynflags' {ghcLink = NoLink,+ ghcMode = usedGhcMode}++ -- Prepare and compile all needed targets.+ let files' = map unLoc files+ printErrorAndDie e = printException e >> liftIO exitFailure+ deps <- handleSourceError printErrorAndDie $ do+ ts <- mapM (flip guessTarget Nothing) files'+ setTargets ts+ _ <- load LoadAllTargets+ depanal [] False+ mapM_ (compile cfg dynflags') deps+ + -- Link everything together into a .js file.+ when (performLink cfg) $ liftIO $ do+ flip mapM_ files' $ \file -> do+ logStr $ "Linking " ++ outFile cfg file+ let pkgid = showPpr dynflags $ thisPackage dynflags'+ link cfg pkgid file+ case useGoogleClosure cfg of + Just clopath -> closurize clopath $ outFile cfg file+ _ -> return ()++-- | Do everything required to get a list of STG bindings out of a module.+prepare :: (GhcMonad m) => DynFlags -> ModSummary -> m ([StgBinding], ModuleName)+prepare dynflags theMod = do+ env <- getSession+ let name = moduleName $ ms_mod theMod+ pgm <- parseModule theMod+ >>= typecheckModule+ >>= desugarModule+ >>= liftIO . hscSimplify env . coreModule+ >>= liftIO . tidyProgram env+ >>= prepPgm env . fst+ >>= liftIO . coreToStg dynflags+ return (pgm, name)+ where+ prepPgm env tidy = liftIO $ do+ prepd <- corePrepPgm dynflags env (cg_binds tidy) (cg_tycons tidy)+ return prepd+++-- | Run Google Closure on a file.+closurize :: FilePath -> FilePath -> IO ()+closurize cloPath file = do+ logStr $ "Running the Google Closure compiler on " ++ file ++ "..."+ let cloFile = file `addExtension` ".clo"+ cloOut <- openFile cloFile WriteMode+ build <- runProcess "java"+ ["-jar", cloPath, "--compilation_level", "ADVANCED_OPTIMIZATIONS",+ "--jscomp_off", "uselessCode", "--jscomp_off", "globalThis",+ file]+ Nothing+ Nothing+ Nothing+ (Just cloOut)+ Nothing+ res <- waitForProcess build+ hClose cloOut+ case res of+ ExitFailure n ->+ fail $ "Couldn't execute Google Closure compiler: " ++ show n+ ExitSuccess ->+ renameFile cloFile file++-- | Generate a unique fingerprint for the compiler, command line arguments,+-- etc.+genFingerprint :: String -> FilePath -> [String] -> Fingerprint+genFingerprint modname targetpath args =+ {- md5sum $ B.pack $ -} show [+ modname,+ targetpath,+ show bootVersion,+ show args+ ]++-- | Compile a module into a .jsmod intermediate file.+compile :: (GhcMonad m) => Config -> DynFlags -> ModSummary -> m ()+compile cfg dynflags modSummary = do+ fp <- liftIO $ fmap (genFingerprint myName targetpath) getArgs+ should_recompile <- liftIO $ shouldRecompile fp modSummary targetpath+ when should_recompile $ do+ case ms_hsc_src modSummary of+ HsBootFile -> liftIO $ logStr $ "Skipping boot " ++ myName+ _ -> do+ (pgm, name) <- prepare dynflags modSummary+ let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary+ theCode = generate cfg fp pkgid name pgm+ liftIO $ logStr $ "Compiling " ++ myName ++ " into " ++ targetpath+ liftIO $ writeModule targetpath theCode+ where+ myName = moduleNameString $ moduleName $ ms_mod modSummary+ targetpath = targetLibPath cfg++shouldRecompile :: Fingerprint -> ModSummary -> FilePath -> IO Bool+shouldRecompile _ _ _ = return True+{-+shouldRecompile fp ms path = do+ exists <- isFile fpPath+ if exists+ then do+ fp' <- readModuleFingerprint path pkgid modname+ jsmtime <- getModified fpPath+ return $ ms_hs_date ms > jsmtime || fp /= fp'+ else do+ return True+ where+ modname = moduleNameString $ ms_mod_name ms+ file = moduleNameSlashes (ms_mod_name ms) ++ ".jsmod"+ path' = path ++ "/" ++ pkgid ++ "/" ++ file+ pkgid = showOutputable $ modulePackageId $ ms_mod ms+ fpPath = fromString path'+-}
+ src/haste-boot.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}+import Prelude hiding (read)+import System.Directory+import Network.HTTP+import Network.Browser hiding (err)+import Network.URI+import qualified Data.ByteString.Lazy as BS+import Data.Version+import Data.Maybe (fromJust)+import Codec.Compression.BZip+import Codec.Archive.Tar+import System.Environment (getArgs)+import System.IO.Temp+import Control.Monad+import qualified Codec.Archive.Zip as Zip+import Haste.Environment+import Haste.Version+import Control.Shell+import Data.Char (isDigit)++downloadFile :: String -> IO (Either String BS.ByteString)+downloadFile f = do+ (_, rsp) <- Network.Browser.browse $ do+ setAllowRedirects True+ request $ Request {+ rqURI = fromJust $ parseURI f,+ rqMethod = GET,+ rqHeaders = [],+ rqBody = BS.empty+ }+ case rspCode rsp of + (2, _, _) -> return $ Right $ rspBody rsp+ _ -> return $ Left $ rspReason rsp++data Cfg = Cfg {+ getLibs :: Bool,+ getClosure :: Bool,+ useLocalLibs :: Bool+ }++main :: IO ()+main = do+ args <- getArgs+ -- Always get base and closure when forced unless explicitly asked not to;+ -- if not forced, get base and closure when necessary, unless asked not to.+ let forceBoot = elem "--force" args+ libs = if elem "--no-libs" args+ then False+ else forceBoot || needsReboot+ closure = if elem "--no-closure" args+ then False+ else forceBoot || needsReboot+ local = elem "--local" args+ cfg = Cfg {+ getLibs = libs,+ getClosure = closure,+ useLocalLibs = local+ }++ when (needsReboot || forceBoot) $ do+ if local+ then bootHaste cfg "."+ else withSystemTempDirectory "haste" $ bootHaste cfg++bootHaste :: Cfg -> FilePath -> IO ()+bootHaste cfg tmpdir = do+ setCurrentDirectory tmpdir+ when (getLibs cfg) $ do+ when (not $ useLocalLibs cfg) $ do+ fetchLibs tmpdir+ exists <- doesDirectoryExist hasteDir+ when exists $ do+ removeDirectoryRecursive hasteDir+ buildLibs+ when (getClosure cfg) $ do+ installClosure+ Prelude.writeFile bootFile (show bootVersion)++-- | Fetch the Haste base libs.+fetchLibs :: FilePath -> IO ()+fetchLibs tmpdir = do+ putStrLn "Downloading base libs from ekblad.cc"+ res <- downloadFile $ mkUrl hasteVersion+ case res of+ Left err ->+ error $ "Unable to download base libs: " ++ err+ Right f ->+ unpack tmpdir . read . decompress $ f+ where+ mkUrl v =+ "http://ekblad.cc/haste-libs/haste-libs-" ++ showVersion v ++ ".tar.bz2"++-- | Fetch and install the Closure compiler.+installClosure :: IO ()+installClosure = do+ putStrLn "Downloading Google Closure compiler..."+ closure <- downloadFile closureURI+ case closure of+ Left _ ->+ putStrLn "Couldn't download Closure compiler; continuing without."+ Right closure' -> do+ let cloArch = Zip.toArchive closure'+ case Zip.findEntryByPath "compiler.jar" cloArch of+ Just compiler ->+ BS.writeFile closureCompiler+ (Zip.fromEntry compiler)+ _ ->+ putStrLn "Couldn't unpack Closure compiler; continuing without."+ where+ closureURI =+ "http://closure-compiler.googlecode.com/files/compiler-latest.zip"++-- | Build haste's base libs.+buildLibs :: IO ()+buildLibs = do+ res <- shell $ do+ -- Set up dirs and copy includes+ mkdir True $ pkgLibDir+ cpDir "include" hasteDir+ run_ "haste-pkg" ["update", "libraries" </> "rts.pkg"] ""+ + inDirectory "libraries" $ do+ -- Install ghc-prim+ inDirectory "ghc-prim" $ do+ hasteInst ["configure"]+ hasteInst ["build", "--install-jsmods", ghcOpts]+ run_ "haste-install-his" ["ghc-prim-0.3.0.0", "dist" </> "build"] ""+ run_ "haste-pkg" ["update", "packageconfig"] ""+ + -- Install integer-gmp twice, since it may misbehave the first time.+ inDirectory "integer-gmp" $ do+ hasteInst ["install", ghcOpts]+ hasteInst ["install", ghcOpts]+ + -- Install base+ inDirectory "base" $ do+ basever <- file "base.cabal" >>= return+ . dropWhile (not . isDigit)+ . head+ . filter (not . null)+ . filter (and . zipWith (==) "version")+ . lines+ hasteInst ["configure"]+ hasteInst ["build", "--install-jsmods", ghcOpts]+ let base = "base-" ++ basever+ pkgdb = "--package-db=dist" </> "package.conf.inplace"+ run_ "haste-install-his" [base, "dist" </> "build"] ""+ run_ "haste-copy-pkg" [base, pkgdb] ""+ + -- Install array, fursuit and haste-lib+ forM_ ["array", "fursuit", "haste-lib"] $ \pkg -> do+ inDirectory pkg $ hasteInst ["install"]+ case res of+ Left err -> error err+ _ -> return ()+ where+ ghcOpts =+ "--ghc-options=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ show hostWordSize+ hasteInst args =+ run_ "haste-inst" ("--unbooted" : args) ""
+ src/haste-copy-pkg.hs view
@@ -0,0 +1,56 @@+-- | haste-copy-pkg; copy a package from file or GHC package DB and fix up its+-- paths.+module Main where+import Data.List+import Haste.Environment+import System.Environment (getArgs)+import Control.Shell++main :: IO ()+main = do+ args <- getArgs+ let (pkgdbs, pkgs) = partition ("--package-db=" `isPrefixOf`) args+ if null args+ then do+ putStrLn "Usage: haste-copy-pkg [--package-db=foo.conf] <packages>"+ else do+ res <- shell (mapM_ (copyFromDB pkgdbs) pkgs)+ case res of+ Left err -> error err+ _ -> return ()++copyFromDB :: [String] -> String -> Shell ()+copyFromDB pkgdbs package = do+ pkgdesc <- run "ghc-pkg" (["describe", package] ++ pkgdbs) ""+ run_ "haste-pkg" ["update", "-", "--force"] (fixPaths package pkgdesc)++-- | Hack a config to work with Haste.+fixPaths :: String -> String -> String+fixPaths pkgname pkgtext =+ pkgtext'+ where+ pkgtext' = unlines+ . map fixPath+ . filter (not . ("haddock" `isPrefixOf`))+ . filter (not . ("hs-libraries:" `isPrefixOf`))+ $ lines pkgtext+ + fixPath str+ | isKey "library-dirs:" str =+ "library-dirs: " ++ importDir </> pkgname+ | isKey "import-dirs:" str =+ "import-dirs: " ++ importDir </> pkgname+ | isKey "pkgroot:" str =+ "pkgroot: \"" ++ pkgRoot ++ "\""+ | "-inplace" `isSuffixOf` str =+ reverse $ drop (length "-inplace") $ reverse str+ | otherwise =+ str++ isKey _ "" =+ False+ isKey key str =+ and $ zipWith (==) key str+ + importDir = pkgLibDir+ pkgRoot = hasteInstDir
+ src/haste-inst.hs view
@@ -0,0 +1,36 @@+-- | haste-inst - Haste wrapper for cabal.+module Main where+import System.FilePath+import System.Environment+import Haste.Environment+import Data.List++type Match = (String -> Bool, [String] -> [String])++cabal :: [String] -> IO ()+cabal args = do+ runAndWait "cabal" (hasteargs ++ args) Nothing+ where+ hasteargs + | "build" `elem` args =+ ["--with-ghc=" ++ hasteBinary]+ | otherwise =+ ["--with-compiler=" ++ hasteBinary,+ "--with-hc-pkg=" ++ hastePkgBinary,+ "--with-hsc2hs=hsc2hs",+ "--prefix=" ++ hasteInstDir,+ "--package-db=" ++ pkgDir]++main :: IO ()+main = do+ as <- getArgs+ as <- return $ if "--install-jsmods" `elem` as || not ("build" `elem` as)+ then libinstall : filter (/= "--install-jsmods") as+ else as+ as <- return $ if "--unbooted" `elem` as+ then unbooted : filter (/= "--unbooted") as+ else as+ cabal as+ where+ libinstall = "--ghc-option=--libinstall"+ unbooted = "--ghc-option=--unbooted"
+ src/haste-install-his.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TupleSections #-}+-- | haste-install-his; install all .hi files in a directory.+module Main where+import Haste.Environment+import System.FilePath+import System.Directory+import System.Environment+import Control.Applicative+import Control.Monad+import Data.List+import Data.Char++main :: IO ()+main = do+ args <- getArgs+ case args of+ [package, dir] -> installFromDir (pkgLibDir </> package) dir+ _ -> putStrLn "Usage: haste-install-his pkgname dir"++getHiFiles :: FilePath -> IO [FilePath]+getHiFiles dir =+ filter (".hi" `isSuffixOf`) <$> getDirectoryContents dir++getSubdirs :: FilePath -> IO [FilePath]+getSubdirs dir = do+ contents <- getDirectoryContents dir+ someDirs <- mapM (\d -> (d,) <$> doesDirectoryExist (dir </> d)) contents+ return [path | (path, isDir) <- someDirs+ , isDir+ , head path /= '.'+ , isUpper (head path)]++installFromDir :: FilePath -> FilePath -> IO ()+installFromDir base path = do+ hiFiles <- getHiFiles path+ when (not $ null hiFiles) $ do+ createDirectoryIfMissing True (pkgLibDir </> base)+ mapM_ (installHiFile base path) hiFiles+ getSubdirs path >>= mapM_ (\d -> installFromDir (base </> d) (path </> d))++installHiFile :: FilePath -> FilePath -> FilePath -> IO ()+installHiFile to from file = do+ putStrLn $ "Installing " ++ from </> file ++ "..."+ copyFile (from </> file) (to </> file)
+ src/haste-pkg.hs view
@@ -0,0 +1,19 @@+-- | haste-pkg; wrapper for ghc-pkg.+module Main where+import Control.Monad+import System.Environment+import System.Directory+import Haste.Environment++main = do+ args <- getArgs+ pkgDirExists <- doesDirectoryExist pkgDir+ when (not pkgDirExists) $ do+ createDirectoryIfMissing True pkgLibDir+ runAndWait "ghc-pkg" ["init", pkgDir] Nothing+ runAndWait "ghc-pkg" (packages ++ map userToGlobal args) Nothing+ where+ packages = ["--no-user-package-db",+ "--global-package-db=" ++ pkgDir]+ userToGlobal "--user" = "--global"+ userToGlobal str = str