haste-compiler 0.2.1 → 0.2.2
raw patch · 14 files changed
+167/−96 lines, 14 files
Files
- haste-compiler.cabal +2/−1
- lib/Integer.js +4/−4
- lib/MVar.js +2/−2
- lib/rts.js +17/−24
- lib/stdlib.js +25/−33
- lib/unicode.js +56/−0
- src/ArgSpecs.hs +2/−4
- src/Data/JSTarget/Constructors.hs +20/−1
- src/Data/JSTarget/Optimize.hs +6/−1
- src/Data/JSTarget/Print.hs +11/−4
- src/Haste/CodeGen.hs +13/−19
- src/Haste/Config.hs +1/−1
- src/Haste/PrimOps.hs +7/−1
- src/Haste/Version.hs +1/−1
haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name: haste-compiler-Version: 0.2.1+Version: 0.2.2 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler@@ -29,6 +29,7 @@ md5.js array.js pointers.js+ unicode.js debug.js Executable haste-boot
lib/Integer.js view
@@ -77,7 +77,7 @@ result = I_add(I_mul(result, power), I_fromNumber(value)); } else { result = I_mul(result, radixToPower);- result = I_add(add, I_fromNumber(value));+ result = I_add(result, I_fromNumber(value)); } } return result;@@ -324,11 +324,11 @@ } var I_quotRem = function(self, other) {- return [1, I_quot(self, other), I_rem(self, other)];+ return [0, I_quot(self, other), I_rem(self, other)]; } var I_divMod = function(self, other) {- return [1, I_div(self, other), I_mod(self, other)];+ return [0, I_div(self, other), I_mod(self, other)]; } var I_quot = function(self, other) {@@ -468,7 +468,7 @@ if(dec[1] < 0) { mantissa = I_negate(mantissa); }- return [1, dec[4], mantissa];+ return [0, dec[4], mantissa]; } var I_toString = function(self) {
lib/MVar.js view
@@ -9,11 +9,11 @@ function tryTakeMVar(mv) { if(mv.empty) {- return [1, 0, undefined];+ return [0, 0, undefined]; } else { mv.empty = true; mv.x = null;- return [1, 1, mv.x];+ return [0, 1, mv.x]; } }
lib/rts.js view
@@ -8,10 +8,6 @@ */ function T(f) {- return new Thunk(f);-}--function Thunk(f) { this.f = f; } @@ -22,7 +18,7 @@ function) is then applied to the remaining arguments. */ function A(f, args) {- f = f instanceof Thunk ? E(f) : f;+ f = f instanceof T ? 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.@@ -52,7 +48,7 @@ If the "thunk" we get isn't actually a thunk, just return it. */ function E(t) {- if(t instanceof Thunk) {+ if(t instanceof T) { if(t.f) { t.x = t.f(); t.f = 0;@@ -74,7 +70,7 @@ } function quotRemI(a, b) {- return [1, (a-a%b)/b, a%b];+ return [0, (a-a%b)/b, a%b]; } // 32 bit integer multiplication, with correct overflow behavior@@ -90,12 +86,12 @@ function addC(a, b) { var x = a+b;- return [1, x & 0xffffffff, x > 0x7fffffff];+ return [0, x & 0xffffffff, x > 0x7fffffff]; } function subC(a, b) { var x = a-b;- return [1, x & 0xffffffff, x < -2147483648];+ return [0, x & 0xffffffff, x < -2147483648]; } function sinh (arg) {@@ -126,7 +122,7 @@ } else { man |= (1 << 23); }- return [1, sign*man, exp];+ return [0, sign*man, exp]; } function decodeDouble(x) {@@ -140,7 +136,7 @@ } else { manHigh |= (1 << 20); }- return [1, sign, manHigh, manLow, exp];+ return [0, sign, manHigh, manLow, exp]; } function err(str) {@@ -150,12 +146,12 @@ /* unpackCString# NOTE: update constructor tags if the code generator starts munging them. */-function unCStr(str) {return unAppCStr(str, [1]);}+function unCStr(str) {return unAppCStr(str, [0]);} 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]);+ acc = A(f, [[0, str.charCodeAt(i)], acc]); } return acc; }@@ -165,7 +161,7 @@ if(i >= str.length) { return E(chrs); } else {- return [2,[1,str.charCodeAt(i)],T(function() {+ return [1,[0,str.charCodeAt(i)],new T(function() { return unAppCStr(str,chrs,i+1); })]; }@@ -179,10 +175,10 @@ function toJSStr(hsstr) { var s = '';- for(var str = E(hsstr); str[0] == 2; str = E(str[2])) {+ for(var str = E(hsstr); str[0] == 1; str = E(str[2])) { s += String.fromCharCode(E(str[1])[1]); }- return [1,s];+ return [0,s]; } // newMutVar@@ -227,15 +223,12 @@ } function strOrd(a, b) {- var ord; if(a < b) {- ord = [1];+ return [0]; } else if(a == b) {- ord = [2];- } else {- ord = [3];+ return [1]; }- return ord;+ return [2]; } function jsCatch(act, handler) {@@ -267,9 +260,9 @@ */ function dataToTag(x) { if(x instanceof Array) {- return x[0]-1;+ return x[0]; } else {- return x-1;+ return x; } }
lib/stdlib.js view
@@ -45,7 +45,7 @@ if(evt == 'change' && elem.type.toLowerCase() == 'text') { setCB(elem, 'keyup', function(k) { if(k == '\n'.charCodeAt(0)) {- A(cb,[[1,k.keyCode],0]);+ A(cb,[[0,k.keyCode],0]); } }); }@@ -56,12 +56,12 @@ case 'dblclick': case 'mouseup': case 'mousedown':- fun = function(x) {A(cb,[[1,x.button],0]);};+ fun = function(x) {A(cb,[[0,x.button],0]);}; break; case 'keypress': case 'keyup': case 'keydown':- fun = function(x) {A(cb,[[1,x.keyCode],0]);};+ fun = function(x) {A(cb,[[0,x.keyCode],0]);}; break; default: fun = function() {A(cb,[0]);};@@ -130,9 +130,9 @@ function jsFind(elem) { var e = document.getElementById(elem) if(e) {- return [2,[1,e]];+ return [1,[0,e]]; }- return [1];+ return [0]; } function jsCreateElem(tag) {@@ -143,29 +143,29 @@ elem = elem.previousSibling; while(elem) { if(typeof elem.tagName != 'undefined') {- return [2,[1,elem]];+ return [1,[0,elem]]; } elem = elem.previousSibling; }- return [1];+ return [0]; } 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,[0,elem.childNodes[i]]]; } }- return [1];+ return [0]; } function jsGetChildren(elem) {- var children = [1];+ var children = [0]; 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];+ children = [1, [0,elem.childNodes[i]], children]; } } return children;@@ -174,7 +174,7 @@ function jsSetChildren(elem, children) { children = E(children); jsClearChildren(elem, 0);- while(children[0] === 2) {+ while(children[0] === 1) { elem.appendChild(E(E(children[1])[1])); children = E(children[2]); }@@ -218,24 +218,24 @@ var js = JSON.parse(str); var hs = toHS(js); } catch(_) {- return [1];+ return [0]; }- return [2,hs];+ return [1,hs]; } function toHS(obj) { switch(typeof obj) { case 'number':- return [1, [1, jsRead(obj)]];+ return [0, [0, jsRead(obj)]]; case 'string':- return [2, [1, obj]];+ return [1, [0, obj]]; break; case 'boolean':- return [3, obj]; // Booleans are special wrt constructor tags!+ return [2, obj]; // Booleans are special wrt constructor tags! break; case 'object': if(obj instanceof Array) {- return [4, arr2lst(obj, 0)];+ return [3, 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@@ -247,20 +247,20 @@ for(var k in obj) { ks.unshift(k); }- var xs = [1];+ var xs = [0]; for(var i in ks) {- xs = [2, [1, [1,ks[i]], toHS(obj[ks[i]])], xs];+ xs = [1, [0, [0,ks[i]], toHS(obj[ks[i]])], xs]; }- return [5, xs];+ return [4, xs]; } } } function arr2lst(arr, elem) { if(elem >= arr.length) {- return [1];+ return [0]; }- return [2, toHS(arr[elem]), T(function() {return arr2lst(arr,elem+1);})]+ return [1, toHS(arr[elem]), new T(function() {return arr2lst(arr,elem+1);})] } function ajaxReq(method, url, async, postdata, cb) {@@ -270,19 +270,11 @@ xhr.onreadystatechange = function() { if(xhr.readyState == 4) { if(xhr.status == 200) {- A(cb,[[2,[1,xhr.responseText]],0]);+ A(cb,[[1,[0,xhr.responseText]],0]); } else {- A(cb,[[1],0]); // Nothing+ A(cb,[[0],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); }
+ lib/unicode.js view
@@ -0,0 +1,56 @@+function withChar(f, charCode) {+ return f(String.fromCharCode(charCode)).charCodeAt(0);+}++function u_towlower(charCode) {+ return withChar(function(c) {return c.toLowerCase()}, charCode);+}++function u_towupper(charCode) {+ return withChar(function(c) {return c.toUpperCase()}, charCode);+}++var u_towtitle = u_towupper;++function u_iswupper(charCode) {+ var c = String.fromCharCode(charCode);+ return isNaN(c*1) && c == c.toUpperCase();+}++function u_iswlower(charCode) {+ var c = String.fromCharCode(charCode);+ return isNaN(c*1) && c == c.toLowerCase();+}++function u_iswdigit(charCode) {+ return charCode >= 48 && charCode <= 57;+}++function u_iswcntrl(charCode) {+ return charCode <= 0x1f || charCode == 0x7f;+}++function u_iswspace(charCode) {+ var c = String.fromCharCode(charCode);+ return c.replace(/\s/g,'') != c;+}++function u_iswalpha(charCode) {+ var c = String.fromCharCode(charCode);+ return c.replace(__hs_alphare, '') != c;+}++function u_iswalnum(charCode) {+ return u_iswdigit(charCode) || u_iswalpha(charCode);+}++function u_iswprint(charCode) {+ return !u_iswcntrl(charCode);+}++function u_gencat(c) {+ throw 'u_gencat is not supported; submit a patch if you want it to be';+}++// Regex that matches any alphabetic character in any language. Horrible thing.+var __hs_alphare = /[\u0041-\u005A\u0061-\u007A\u00AA\u00B5\u00BA\u00C0-\u00D6\u00D8-\u00F6\u00F8-\u02C1\u02C6-\u02D1\u02E0-\u02E4\u02EC\u02EE\u0370-\u0374\u0376\u0377\u037A-\u037D\u0386\u0388-\u038A\u038C\u038E-\u03A1\u03A3-\u03F5\u03F7-\u0481\u048A-\u0527\u0531-\u0556\u0559\u0561-\u0587\u05D0-\u05EA\u05F0-\u05F2\u0620-\u064A\u066E\u066F\u0671-\u06D3\u06D5\u06E5\u06E6\u06EE\u06EF\u06FA-\u06FC\u06FF\u0710\u0712-\u072F\u074D-\u07A5\u07B1\u07CA-\u07EA\u07F4\u07F5\u07FA\u0800-\u0815\u081A\u0824\u0828\u0840-\u0858\u08A0\u08A2-\u08AC\u0904-\u0939\u093D\u0950\u0958-\u0961\u0971-\u0977\u0979-\u097F\u0985-\u098C\u098F\u0990\u0993-\u09A8\u09AA-\u09B0\u09B2\u09B6-\u09B9\u09BD\u09CE\u09DC\u09DD\u09DF-\u09E1\u09F0\u09F1\u0A05-\u0A0A\u0A0F\u0A10\u0A13-\u0A28\u0A2A-\u0A30\u0A32\u0A33\u0A35\u0A36\u0A38\u0A39\u0A59-\u0A5C\u0A5E\u0A72-\u0A74\u0A85-\u0A8D\u0A8F-\u0A91\u0A93-\u0AA8\u0AAA-\u0AB0\u0AB2\u0AB3\u0AB5-\u0AB9\u0ABD\u0AD0\u0AE0\u0AE1\u0B05-\u0B0C\u0B0F\u0B10\u0B13-\u0B28\u0B2A-\u0B30\u0B32\u0B33\u0B35-\u0B39\u0B3D\u0B5C\u0B5D\u0B5F-\u0B61\u0B71\u0B83\u0B85-\u0B8A\u0B8E-\u0B90\u0B92-\u0B95\u0B99\u0B9A\u0B9C\u0B9E\u0B9F\u0BA3\u0BA4\u0BA8-\u0BAA\u0BAE-\u0BB9\u0BD0\u0C05-\u0C0C\u0C0E-\u0C10\u0C12-\u0C28\u0C2A-\u0C33\u0C35-\u0C39\u0C3D\u0C58\u0C59\u0C60\u0C61\u0C85-\u0C8C\u0C8E-\u0C90\u0C92-\u0CA8\u0CAA-\u0CB3\u0CB5-\u0CB9\u0CBD\u0CDE\u0CE0\u0CE1\u0CF1\u0CF2\u0D05-\u0D0C\u0D0E-\u0D10\u0D12-\u0D3A\u0D3D\u0D4E\u0D60\u0D61\u0D7A-\u0D7F\u0D85-\u0D96\u0D9A-\u0DB1\u0DB3-\u0DBB\u0DBD\u0DC0-\u0DC6\u0E01-\u0E30\u0E32\u0E33\u0E40-\u0E46\u0E81\u0E82\u0E84\u0E87\u0E88\u0E8A\u0E8D\u0E94-\u0E97\u0E99-\u0E9F\u0EA1-\u0EA3\u0EA5\u0EA7\u0EAA\u0EAB\u0EAD-\u0EB0\u0EB2\u0EB3\u0EBD\u0EC0-\u0EC4\u0EC6\u0EDC-\u0EDF\u0F00\u0F40-\u0F47\u0F49-\u0F6C\u0F88-\u0F8C\u1000-\u102A\u103F\u1050-\u1055\u105A-\u105D\u1061\u1065\u1066\u106E-\u1070\u1075-\u1081\u108E\u10A0-\u10C5\u10C7\u10CD\u10D0-\u10FA\u10FC-\u1248\u124A-\u124D\u1250-\u1256\u1258\u125A-\u125D\u1260-\u1288\u128A-\u128D\u1290-\u12B0\u12B2-\u12B5\u12B8-\u12BE\u12C0\u12C2-\u12C5\u12C8-\u12D6\u12D8-\u1310\u1312-\u1315\u1318-\u135A\u1380-\u138F\u13A0-\u13F4\u1401-\u166C\u166F-\u167F\u1681-\u169A\u16A0-\u16EA\u1700-\u170C\u170E-\u1711\u1720-\u1731\u1740-\u1751\u1760-\u176C\u176E-\u1770\u1780-\u17B3\u17D7\u17DC\u1820-\u1877\u1880-\u18A8\u18AA\u18B0-\u18F5\u1900-\u191C\u1950-\u196D\u1970-\u1974\u1980-\u19AB\u19C1-\u19C7\u1A00-\u1A16\u1A20-\u1A54\u1AA7\u1B05-\u1B33\u1B45-\u1B4B\u1B83-\u1BA0\u1BAE\u1BAF\u1BBA-\u1BE5\u1C00-\u1C23\u1C4D-\u1C4F\u1C5A-\u1C7D\u1CE9-\u1CEC\u1CEE-\u1CF1\u1CF5\u1CF6\u1D00-\u1DBF\u1E00-\u1F15\u1F18-\u1F1D\u1F20-\u1F45\u1F48-\u1F4D\u1F50-\u1F57\u1F59\u1F5B\u1F5D\u1F5F-\u1F7D\u1F80-\u1FB4\u1FB6-\u1FBC\u1FBE\u1FC2-\u1FC4\u1FC6-\u1FCC\u1FD0-\u1FD3\u1FD6-\u1FDB\u1FE0-\u1FEC\u1FF2-\u1FF4\u1FF6-\u1FFC\u2071\u207F\u2090-\u209C\u2102\u2107\u210A-\u2113\u2115\u2119-\u211D\u2124\u2126\u2128\u212A-\u212D\u212F-\u2139\u213C-\u213F\u2145-\u2149\u214E\u2183\u2184\u2C00-\u2C2E\u2C30-\u2C5E\u2C60-\u2CE4\u2CEB-\u2CEE\u2CF2\u2CF3\u2D00-\u2D25\u2D27\u2D2D\u2D30-\u2D67\u2D6F\u2D80-\u2D96\u2DA0-\u2DA6\u2DA8-\u2DAE\u2DB0-\u2DB6\u2DB8-\u2DBE\u2DC0-\u2DC6\u2DC8-\u2DCE\u2DD0-\u2DD6\u2DD8-\u2DDE\u2E2F\u3005\u3006\u3031-\u3035\u303B\u303C\u3041-\u3096\u309D-\u309F\u30A1-\u30FA\u30FC-\u30FF\u3105-\u312D\u3131-\u318E\u31A0-\u31BA\u31F0-\u31FF\u3400-\u4DB5\u4E00-\u9FCC\uA000-\uA48C\uA4D0-\uA4FD\uA500-\uA60C\uA610-\uA61F\uA62A\uA62B\uA640-\uA66E\uA67F-\uA697\uA6A0-\uA6E5\uA717-\uA71F\uA722-\uA788\uA78B-\uA78E\uA790-\uA793\uA7A0-\uA7AA\uA7F8-\uA801\uA803-\uA805\uA807-\uA80A\uA80C-\uA822\uA840-\uA873\uA882-\uA8B3\uA8F2-\uA8F7\uA8FB\uA90A-\uA925\uA930-\uA946\uA960-\uA97C\uA984-\uA9B2\uA9CF\uAA00-\uAA28\uAA40-\uAA42\uAA44-\uAA4B\uAA60-\uAA76\uAA7A\uAA80-\uAAAF\uAAB1\uAAB5\uAAB6\uAAB9-\uAABD\uAAC0\uAAC2\uAADB-\uAADD\uAAE0-\uAAEA\uAAF2-\uAAF4\uAB01-\uAB06\uAB09-\uAB0E\uAB11-\uAB16\uAB20-\uAB26\uAB28-\uAB2E\uABC0-\uABE2\uAC00-\uD7A3\uD7B0-\uD7C6\uD7CB-\uD7FB\uF900-\uFA6D\uFA70-\uFAD9\uFB00-\uFB06\uFB13-\uFB17\uFB1D\uFB1F-\uFB28\uFB2A-\uFB36\uFB38-\uFB3C\uFB3E\uFB40\uFB41\uFB43\uFB44\uFB46-\uFBB1\uFBD3-\uFD3D\uFD50-\uFD8F\uFD92-\uFDC7\uFDF0-\uFDFB\uFE70-\uFE74\uFE76-\uFEFC\uFF21-\uFF3A\uFF41-\uFF5A\uFF66-\uFFBE\uFFC2-\uFFC7\uFFCA-\uFFCF\uFFD2-\uFFD7\uFFDA-\uFFDC]/g;
src/ArgSpecs.hs view
@@ -20,12 +20,10 @@ 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."},+ ++ "Equivalent to -O2 --opt-google-closure."}, ArgSpec { optName = "opt-all-unsafe", updateCfg = optAllUnsafe, info = "Enable all safe and unsafe optimizations.\n"@@ -108,7 +106,7 @@ -- | Enable all safe optimizations. optAllSafe :: Config -> [String] -> Config-optAllSafe = updateClosureCfg ||| enableWholeProgramOpts+optAllSafe = updateClosureCfg -- | Set the path to the Closure compiler.jar to use. updateClosureCfg :: Config -> [String] -> Config
src/Data/JSTarget/Constructors.hs view
@@ -84,7 +84,26 @@ -- | Create a thunk. thunk :: AST Stm -> AST Exp-thunk stm = callForeign "T" [Fun Nothing [] <$> stm]+thunk stm@(AST s js) =+ case s of+ (Return ex) | not $ evaluates ex ->+ AST ex js+ _ ->+ callForeign "new T" [Fun Nothing [] <$> stm]++-- | Returns True if the given expression causes evaluation by appearing+-- outside a closure, otherwise False.+evaluates :: Exp -> Bool+evaluates (Var _) = False+evaluates (Lit _) = False+evaluates (Not ex) = evaluates ex+evaluates (BinOp _ a b) = evaluates a || evaluates b+evaluates (Fun _ _ _) = False+evaluates (Call _ _ _ _) = True+evaluates (Index a b) = evaluates a || evaluates b+evaluates (Arr xs) = any evaluates xs+evaluates (AssignEx a b) = evaluates a || evaluates b+evaluates (IfEx c a b) = evaluates c || evaluates a || evaluates b -- | Evaluate an expression that may or may not be a thunk. eval :: AST Exp -> AST Exp
src/Data/JSTarget/Optimize.hs view
@@ -88,7 +88,7 @@ inlineAssigns :: JSTrav ast => Bool -> ast -> TravM ast inlineAssigns blackholeOK ast = do inlinable <- gatherInlinable ast- mapJS (const True) return (inl inlinable) ast+ mapJS (const True) inlEx (inl inlinable) ast where varOccurs lhs (Exp (Var lhs')) = lhs == lhs' varOccurs _ _ = False@@ -117,6 +117,11 @@ else do return keep inl _ stm = return stm++ inlEx (Index (Arr xs) (Lit (LNum n))) =+ return $ xs !! truncate n+ inlEx x =+ return x -- | Gather a map of all inlinable symbols; that is, the once that are used -- exactly once.
src/Data/JSTarget/Print.hs view
@@ -160,11 +160,11 @@ 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+ neg' c = maybe (Not c) id (neg c) prettyCase _ def [] = do pp def prettyCase cond def alts = do@@ -209,9 +209,16 @@ else pp x -- | Normalize an operator expression by shifting parentheses to the left for--- all associative operators.+-- all associative operators and eliminating comparisons with true/false. norm :: Exp -> Exp norm (BinOp op a (BinOp op' b c)) | op == op' && opIsAssoc op = norm (BinOp op (BinOp op a b) c)-norm e =- e+norm (BinOp Eq a (Lit (LBool True))) = norm a+norm (BinOp Eq (Lit (LBool True)) b) = norm b+norm (BinOp Eq a (Lit (LBool False))) = Not (norm a)+norm (BinOp Eq (Lit (LBool False)) b) = Not (norm b)+norm (BinOp Neq a (Lit (LBool True))) = Not (norm a)+norm (BinOp Neq (Lit (LBool True)) b) = Not (norm b)+norm (BinOp Neq a (Lit (LBool False))) = norm a+norm (BinOp Neq (Lit (LBool False)) b) = norm b+norm e = e
src/Haste/CodeGen.hs view
@@ -30,7 +30,7 @@ import BasicTypes -- AST stuff import Data.JSTarget as J-import Data.JSTarget.AST (Exp (..), Stm (..), LHS (..), Lit (..))+import Data.JSTarget.AST (Exp (..), Stm (..), LHS (..)) -- General Haste stuff import Haste.Config import Haste.Monad@@ -116,7 +116,7 @@ _ -> mkCon tag args' stricts' where -- Always inline bools- mkCon l@(AST (Lit (LBool _)) _) _ _ = return l+ mkCon l _ _ | isEnumerationDataCon con = return l mkCon tag as ss = return $ array (tag : zipWith evaluate as ss) evaluate arg True = eval arg evaluate arg _ = arg@@ -267,18 +267,10 @@ getTag s = index s (litN 0) cmp = case t of PrimAlt _ -> id- AlgAlt tc -> if tyConIsBoolean tc then id else getTag+ AlgAlt tc -> if isEnumerationTyCon 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.@@ -400,14 +392,11 @@ -- (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))+ if isEnumerationDataCon dc+ then return (tagexp, [])+ else return (tagexp, map strict (dataConRepStrictness dc)) where+ tagexp = genDataConTag dc strict MarkedStrict = True strict _ = False @@ -423,7 +412,8 @@ case (n, m) of ("True", "GHC.Types") -> lit True ("False", "GHC.Types") -> lit False- _ -> lit (fromIntegral $ dataConTag d :: Double)+ _ ->+ lit (fromIntegral (dataConTag d - fIRST_TAG) :: Double) -- | Generate literals. genLit :: L.Literal -> JSGen Config (AST Exp)@@ -463,6 +453,10 @@ else return $ call arity f' xs' where arity = arityInfo $ idInfo f++-- | Does this data constructor create an enumeration type?+isEnumerationDataCon :: DataCon -> Bool+isEnumerationDataCon = isEnumerationTyCon . dataConTyCon -- | Returns True if the given Var is an unboxed tuple with a single element -- after any represenationless elements are discarded.
src/Haste/Config.hs view
@@ -16,7 +16,7 @@ stdJSLibs :: [FilePath] stdJSLibs = unsafePerformIO $ mapM getDataFileName [ "rts.js", "stdlib.js", "MVar.js", "StableName.js", "Integer.js", "md5.js",- "array.js", "pointers.js"+ "array.js", "pointers.js", "unicode.js" ] debugLib :: FilePath
src/Haste/PrimOps.hs view
@@ -210,6 +210,8 @@ NewMutVarOp -> callF "nMV" ReadMutVarOp -> callF "rMV" WriteMutVarOp -> callF "wMV"+ SameMutVarOp -> bOp Eq+ AtomicModifyMutVarOp -> Right $ callSaturated (xs !! 1) [(xs !! 0)] -- TVars - since there's no parallelism and no preemption, TVars behave -- just like normal IORefs.@@ -219,6 +221,7 @@ SameTVarOp -> bOp Eq -- Pointer ops+ ReallyUnsafePtrEqualityOp -> bOp Eq WriteOffAddrOp_Char -> writeOffAddr xs "i8" 1 WriteOffAddrOp_Int -> writeOffAddr xs "i32" 4 WriteOffAddrOp_Int8 -> writeOffAddr xs "i8" 1@@ -276,7 +279,7 @@ -- Stable pointers - all pointers are stable in JS! MakeStablePtrOp -> Right $ head xs- EqStablePtrOp -> Right $ head xs+ EqStablePtrOp -> bOp Eq DeRefStablePtrOp -> Right $ head xs -- Exception masking@@ -286,10 +289,13 @@ MaskStatus -> Right $ litN 0 -- Misc. ops+ DelayOp -> Right $ defState SeqOp -> Right $ callForeign "E" [head xs] AtomicallyOp -> Right $ callSaturated (xs !! 0) [] -- Get the data constructor tag from a value. DataToTagOp -> callF "dataToTag"+ -- Basically unsafeCoerce :: Int# -> <enumeration type>+ TagToEnumOp -> Right $ head xs TouchOp -> Right $ defState RaiseOp -> callF "die" RaiseIOOp -> callF "die"
src/Haste/Version.hs view
@@ -10,7 +10,7 @@ import Haste.Environment (hasteDir) hasteVersion :: Version-hasteVersion = Version [0, 2, 1] []+hasteVersion = Version [0, 2, 2] [] ghcVersion :: String ghcVersion = cProjectVersion