haste-compiler 0.2.10 → 0.2.11
raw patch · 10 files changed
+110/−790 lines, 10 filesdep +shellmate
Dependencies added: shellmate
Files
- haste-compiler.cabal +5/−5
- lib/Int64.js +6/−398
- lib/debug.js +1/−3
- lib/rts.js +4/−1
- src/ArgSpecs.hs +3/−4
- src/Control/Shell.hs +0/−290
- src/Haste/Environment.hs +7/−3
- src/Haste/Version.hs +1/−1
- src/Main.hs +1/−1
- src/haste-boot.hs +82/−84
haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name: haste-compiler-Version: 0.2.10+Version: 0.2.11 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler@@ -57,7 +57,6 @@ Other-Modules: Haste.Version Haste.Environment- Control.Shell Hs-Source-Dirs: src if flag(portable-compiler) CPP-Options: -DPORTABLE_COMPILER@@ -78,7 +77,8 @@ transformers, network, HTTP,- executable-path+ executable-path,+ shellmate >= 0.1.1 Default-Language: Haskell98 Executable hastec@@ -183,7 +183,6 @@ Main-Is: haste-copy-pkg.hs Other-Modules: Haste.Environment- Control.Shell Hs-Source-Dirs: src if flag(portable-compiler) CPP-Options: -DPORTABLE_COMPILER@@ -197,5 +196,6 @@ temporary, time, transformers,- executable-path+ executable-path,+ shellmate default-language: Haskell98
lib/Int64.js view
@@ -12,61 +12,13 @@ // See the License for the specific language governing permissions and // limitations under the License. -/**- * Constructs a 64-bit two's-complement integer, given its low and high 32-bit- * values as *signed* integers. See the from* functions below for more- * convenient ways of constructing Longs.- *- * The internal representation of a long is the two given signed, 32-bit values.- * We use 32-bit pieces because these are the size of integers on which- * Javascript performs bit-operations. For operations like addition and- * multiplication, we split each number into 16-bit pieces, which can easily be- * multiplied within Javascript's floating-point representation without overflow- * or change in sign.- *- * In the algorithms below, we frequently reduce the negative case to the- * positive case by negating the input(s) and then post-processing the result.- * Note that we must ALWAYS check specially whether those values are MIN_VALUE- * (-2^63) because -MIN_VALUE == MIN_VALUE (since 2^63 cannot be represented as- * a positive number, it overflows back into a negative). Not handling this- * case would often result in infinite recursion.- *- * @param {number} low The low (signed) 32 bits of the long.- * @param {number} high The high (signed) 32 bits of the long.- * @constructor- */ Long = function(low, high) {- /**- * @type {number}- * @private- */- this.low_ = low | 0; // force into 32 signed bits.-- /**- * @type {number}- * @private- */- this.high_ = high | 0; // force into 32 signed bits.+ this.low_ = low | 0;+ this.high_ = high | 0; }; --// NOTE: Common constant values ZERO, ONE, NEG_ONE, etc. are defined below the-// from* methods on which they depend.---/**- * A cache of the Long representations of small integer values.- * @type {!Object}- * @private- */ Long.IntCache_ = {}; --/**- * Returns a Long representing the given (32-bit) integer value.- * @param {number} value The 32-bit integer in question.- * @return {!Long} The corresponding Long value.- */ Long.fromInt = function(value) { if (-128 <= value && value < 128) { var cachedObj = Long.IntCache_[value];@@ -82,13 +34,6 @@ return obj; }; --/**- * Returns a Long representing the given value, provided that it is a finite- * number. Otherwise, zero is returned.- * @param {number} value The number in question.- * @return {!Long} The corresponding Long value.- */ Long.fromNumber = function(value) { if (isNaN(value) || !isFinite(value)) { return Long.ZERO;@@ -105,335 +50,88 @@ } }; --/**- * Returns a Long representing the 64-bit integer that comes by concatenating- * the given high and low bits. Each is assumed to use 32 bits.- * @param {number} lowBits The low 32-bits.- * @param {number} highBits The high 32-bits.- * @return {!Long} The corresponding Long value.- */ Long.fromBits = function(lowBits, highBits) { return new Long(lowBits, highBits); }; --/**- * Returns a Long representation of the given string, written using the given- * radix.- * @param {string} str The textual representation of the Long.- * @param {number=} opt_radix The radix in which the text is written.- * @return {!Long} The corresponding Long value.- */-Long.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 Long.fromString(str.substring(1), radix).negate();- } else if (str.indexOf('-') >= 0) {- throw Error('number format error: interior "-" character: ' + str);- }-- // Do several (8) digits each time through the loop, so as to- // minimize the calls to the very expensive emulated div.- var radixToPower = Long.fromNumber(Math.pow(radix, 8));-- var result = Long.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 = Long.fromNumber(Math.pow(radix, size));- result = result.multiply(power).add(Long.fromNumber(value));- } else {- result = result.multiply(radixToPower);- result = result.add(Long.fromNumber(value));- }- }- return result;-};---// NOTE: the compiler should inline these constant values below and then remove-// these variables, so there should be no runtime penalty for these.---/**- * Number used repeated below in calculations. This must appear before the- * first call to any from* function below.- * @type {number}- * @private- */ Long.TWO_PWR_16_DBL_ = 1 << 16;---/**- * @type {number}- * @private- */ Long.TWO_PWR_24_DBL_ = 1 << 24;---/**- * @type {number}- * @private- */ Long.TWO_PWR_32_DBL_ = Long.TWO_PWR_16_DBL_ * Long.TWO_PWR_16_DBL_;---/**- * @type {number}- * @private- */ Long.TWO_PWR_31_DBL_ = Long.TWO_PWR_32_DBL_ / 2;---/**- * @type {number}- * @private- */ Long.TWO_PWR_48_DBL_ = Long.TWO_PWR_32_DBL_ * Long.TWO_PWR_16_DBL_;---/**- * @type {number}- * @private- */ Long.TWO_PWR_64_DBL_ = Long.TWO_PWR_32_DBL_ * Long.TWO_PWR_32_DBL_;---/**- * @type {number}- * @private- */ Long.TWO_PWR_63_DBL_ = Long.TWO_PWR_64_DBL_ / 2;---/** @type {!Long} */ Long.ZERO = Long.fromInt(0);---/** @type {!Long} */ Long.ONE = Long.fromInt(1);---/** @type {!Long} */ Long.NEG_ONE = Long.fromInt(-1);---/** @type {!Long} */ Long.MAX_VALUE = Long.fromBits(0xFFFFFFFF | 0, 0x7FFFFFFF | 0);---/** @type {!Long} */ Long.MIN_VALUE = Long.fromBits(0, 0x80000000 | 0);---/**- * @type {!Long}- * @private- */ Long.TWO_PWR_24_ = Long.fromInt(1 << 24); --/** @return {number} The value, assuming it is a 32-bit integer. */ Long.prototype.toInt = function() { return this.low_; }; --/** @return {number} The closest floating-point representation to this value. */ Long.prototype.toNumber = function() { return this.high_ * Long.TWO_PWR_32_DBL_ + this.getLowBitsUnsigned(); }; --/**- * @param {number=} opt_radix The radix in which the text should be written.- * @return {string} The textual representation of this value.- * @override- */-Long.prototype.toString = function(opt_radix) {- var radix = opt_radix || 10;- if (radix < 2 || 36 < radix) {- throw Error('radix out of range: ' + radix);- }-- if (this.isZero()) {- return '0';- }-- if (this.isNegative()) {- if (this.equals(Long.MIN_VALUE)) {- // We need to change the Long value before it can be negated, so we remove- // the bottom-most digit in this base and then recurse to do the rest.- var radixLong = Long.fromNumber(radix);- var div = this.div(radixLong);- var rem = div.multiply(radixLong).subtract(this);- return div.toString(radix) + rem.toInt().toString(radix);- } else {- return '-' + this.negate().toString(radix);- }- }-- // Do several (6) digits each time through the loop, so as to- // minimize the calls to the very expensive emulated div.- var radixToPower = Long.fromNumber(Math.pow(radix, 6));-- var rem = this;- var result = '';- while (true) {- var remDiv = rem.div(radixToPower);- var intval = rem.subtract(remDiv.multiply(radixToPower)).toInt();- var digits = intval.toString(radix);-- rem = remDiv;- if (rem.isZero()) {- return digits + result;- } else {- while (digits.length < 6) {- digits = '0' + digits;- }- result = '' + digits + result;- }- }-};---/** @return {number} The high 32-bits as a signed value. */ Long.prototype.getHighBits = function() { return this.high_; }; --/** @return {number} The low 32-bits as a signed value. */ Long.prototype.getLowBits = function() { return this.low_; }; --/** @return {number} The low 32-bits as an unsigned value. */ Long.prototype.getLowBitsUnsigned = function() { return (this.low_ >= 0) ? this.low_ : Long.TWO_PWR_32_DBL_ + this.low_; }; --/**- * @return {number} Returns the number of bits needed to represent the absolute- * value of this Long.- */-Long.prototype.getNumBitsAbs = function() {- if (this.isNegative()) {- if (this.equals(Long.MIN_VALUE)) {- return 64;- } else {- return this.negate().getNumBitsAbs();- }- } else {- var val = this.high_ != 0 ? this.high_ : this.low_;- for (var bit = 31; bit > 0; bit--) {- if ((val & (1 << bit)) != 0) {- break;- }- }- return this.high_ != 0 ? bit + 33 : bit + 1;- }-};---/** @return {boolean} Whether this value is zero. */ Long.prototype.isZero = function() { return this.high_ == 0 && this.low_ == 0; }; --/** @return {boolean} Whether this value is negative. */ Long.prototype.isNegative = function() { return this.high_ < 0; }; --/** @return {boolean} Whether this value is odd. */ Long.prototype.isOdd = function() { return (this.low_ & 1) == 1; }; --/**- * @param {Long} other Long to compare against.- * @return {boolean} Whether this Long equals the other.- */ Long.prototype.equals = function(other) { return (this.high_ == other.high_) && (this.low_ == other.low_); }; --/**- * @param {Long} other Long to compare against.- * @return {boolean} Whether this Long does not equal the other.- */ Long.prototype.notEquals = function(other) { return (this.high_ != other.high_) || (this.low_ != other.low_); }; --/**- * @param {Long} other Long to compare against.- * @return {boolean} Whether this Long is less than the other.- */ Long.prototype.lessThan = function(other) { return this.compare(other) < 0; }; --/**- * @param {Long} other Long to compare against.- * @return {boolean} Whether this Long is less than or equal to the other.- */ Long.prototype.lessThanOrEqual = function(other) { return this.compare(other) <= 0; }; --/**- * @param {Long} other Long to compare against.- * @return {boolean} Whether this Long is greater than the other.- */ Long.prototype.greaterThan = function(other) { return this.compare(other) > 0; }; --/**- * @param {Long} other Long to compare against.- * @return {boolean} Whether this Long is greater than or equal to the other.- */ Long.prototype.greaterThanOrEqual = function(other) { return this.compare(other) >= 0; }; --/**- * Compares this Long with the given one.- * @param {Long} other Long to compare against.- * @return {number} 0 if they are the same, 1 if the this is greater, and -1- * if the given one is greater.- */ Long.prototype.compare = function(other) { if (this.equals(other)) { return 0;@@ -448,7 +146,6 @@ return 1; } - // at this point, the signs are the same, so subtraction will not overflow if (this.subtract(other).isNegative()) { return -1; } else {@@ -456,8 +153,6 @@ } }; --/** @return {!Long} The negation of this value. */ Long.prototype.negate = function() { if (this.equals(Long.MIN_VALUE)) { return Long.MIN_VALUE;@@ -466,15 +161,7 @@ } }; --/**- * Returns the sum of this and the given Long.- * @param {Long} other Long to add to this one.- * @return {!Long} The sum of this and the given Long.- */ Long.prototype.add = function(other) {- // Divide each number into 4 chunks of 16 bits, and then sum the chunks.- var a48 = this.high_ >>> 16; var a32 = this.high_ & 0xFFFF; var a16 = this.low_ >>> 16;@@ -500,22 +187,10 @@ return Long.fromBits((c16 << 16) | c00, (c48 << 16) | c32); }; --/**- * Returns the difference of this and the given Long.- * @param {Long} other Long to subtract from this.- * @return {!Long} The difference of this and the given Long.- */ Long.prototype.subtract = function(other) { return this.add(other.negate()); }; --/**- * Returns the product of this and the given long.- * @param {Long} other Long to multiply with this.- * @return {!Long} The product of this and the other.- */ Long.prototype.multiply = function(other) { if (this.isZero()) { return Long.ZERO;@@ -539,15 +214,11 @@ return this.multiply(other.negate()).negate(); } - // If both longs are small, use float multiplication if (this.lessThan(Long.TWO_PWR_24_) && other.lessThan(Long.TWO_PWR_24_)) { return Long.fromNumber(this.toNumber() * other.toNumber()); } - // Divide each long into 4 chunks of 16 bits, and then add up 4x4 products.- // We can skip products that would overflow.- var a48 = this.high_ >>> 16; var a32 = this.high_ & 0xFFFF; var a16 = this.low_ >>> 16;@@ -582,12 +253,6 @@ return Long.fromBits((c16 << 16) | c00, (c48 << 16) | c32); }; --/**- * Returns this Long divided by the given one.- * @param {Long} other Long by which to divide.- * @return {!Long} This Long divided by the given one.- */ Long.prototype.div = function(other) { if (other.isZero()) { throw Error('division by zero');@@ -598,11 +263,10 @@ if (this.equals(Long.MIN_VALUE)) { if (other.equals(Long.ONE) || other.equals(Long.NEG_ONE)) {- return Long.MIN_VALUE; // recall that -MIN_VALUE == MIN_VALUE+ return Long.MIN_VALUE; } else if (other.equals(Long.MIN_VALUE)) { return Long.ONE; } else {- // At this point, we have |other| >= 2, so |this/other| < |MIN_VALUE|. var halfThis = this.shiftRight(1); var approx = halfThis.div(other).shiftLeft(1); if (approx.equals(Long.ZERO)) {@@ -627,25 +291,14 @@ return this.div(other.negate()).negate(); } - // Repeat the following until the remainder is less than other: find a- // floating-point that approximates remainder / other *from below*, add this- // into the result, and subtract it from the remainder. It is critical that- // the approximate value is less than or equal to the real value so that the- // remainder never becomes negative. var res = Long.ZERO; var rem = this; while (rem.greaterThanOrEqual(other)) {- // Approximate the result of division. This may be a little greater or- // smaller than the actual value. var approx = Math.max(1, Math.floor(rem.toNumber() / other.toNumber())); - // We will tweak the approximate result by changing it in the 48-th digit or- // the smallest non-fractional digit, whichever is larger. var log2 = Math.ceil(Math.log(approx) / Math.LN2); var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48); - // Decrease the approximation until it is smaller than the remainder. Note- // that if it is too large, the product overflows and is negative. var approxRes = Long.fromNumber(approx); var approxRem = approxRes.multiply(other); while (approxRem.isNegative() || approxRem.greaterThan(rem)) {@@ -654,8 +307,6 @@ approxRem = approxRes.multiply(other); } - // We know the answer can't be zero... and actually, zero would cause- // infinite recursion since we would make no progress. if (approxRes.isZero()) { approxRes = Long.ONE; }@@ -666,61 +317,29 @@ return res; }; --/**- * Returns this Long modulo the given one.- * @param {Long} other Long by which to mod.- * @return {!Long} This Long modulo the given one.- */ Long.prototype.modulo = function(other) { return this.subtract(this.div(other).multiply(other)); }; --/** @return {!Long} The bitwise-NOT of this value. */ Long.prototype.not = function() { return Long.fromBits(~this.low_, ~this.high_); }; --/**- * Returns the bitwise-AND of this Long and the given one.- * @param {Long} other The Long with which to AND.- * @return {!Long} The bitwise-AND of this and the other.- */ Long.prototype.and = function(other) { return Long.fromBits(this.low_ & other.low_, this.high_ & other.high_); }; --/**- * Returns the bitwise-OR of this Long and the given one.- * @param {Long} other The Long with which to OR.- * @return {!Long} The bitwise-OR of this and the other.- */ Long.prototype.or = function(other) { return Long.fromBits(this.low_ | other.low_, this.high_ | other.high_); }; --/**- * Returns the bitwise-XOR of this Long and the given one.- * @param {Long} other The Long with which to XOR.- * @return {!Long} The bitwise-XOR of this and the other.- */ Long.prototype.xor = function(other) { return Long.fromBits(this.low_ ^ other.low_, this.high_ ^ other.high_); }; --/**- * Returns this Long with bits shifted to the left by the given amount.- * @param {number} numBits The number of bits by which to shift.- * @return {!Long} This shifted to the left by the given amount.- */ Long.prototype.shiftLeft = function(numBits) { numBits &= 63; if (numBits == 0) {@@ -738,12 +357,6 @@ } }; --/**- * Returns this Long with bits shifted to the right by the given amount.- * @param {number} numBits The number of bits by which to shift.- * @return {!Long} This shifted to the right by the given amount.- */ Long.prototype.shiftRight = function(numBits) { numBits &= 63; if (numBits == 0) {@@ -763,14 +376,6 @@ } }; --/**- * Returns this Long with bits shifted to the right by the given amount, with- * the new top bits matching the current sign bit.- * @param {number} numBits The number of bits by which to shift.- * @return {!Long} This shifted to the right by the given amount, with- * zeros placed into the new leading bits.- */ Long.prototype.shiftRightUnsigned = function(numBits) { numBits &= 63; if (numBits == 0) {@@ -790,6 +395,9 @@ } }; +++// Int64 function hs_eqInt64(x, y) {return x.equals(y);} function hs_neInt64(x, y) {return !x.equals(y);} function hs_ltInt64(x, y) {return x.compare(y) < 0;}
lib/debug.js view
@@ -2,9 +2,7 @@ Debugging utilities, tracing, etc. */ -if(typeof print != 'undefined') {- var __h_debug = print;-} else if(typeof console != 'undefined') {+if(typeof console != 'undefined') { var __h_debug = function(x) {console.log(x)}; } else { var __h_debug = alert;
lib/rts.js view
@@ -1,3 +1,6 @@+// This object will hold all exports.+var Haste = {};+ /* Thunk Creates a thunk representing the given closure. Since we want automatic memoization of as many expressions as possible, we@@ -28,7 +31,7 @@ // 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 === undefined) {+ if(!f || f.apply === undefined) { return f; }
src/ArgSpecs.hs view
@@ -29,7 +29,7 @@ ArgSpec { optName = "opt-all", updateCfg = optAllSafe, info = "Enable all safe optimizations. "- ++ "Equivalent to -O2 --opt-google-closure."},+ ++ "Equivalent to -O2 --opt-google-closure --opt-whole-program."}, ArgSpec { optName = "opt-all-unsafe", updateCfg = optAllUnsafe, info = "Enable all safe and unsafe optimizations.\n"@@ -83,8 +83,7 @@ ArgSpec { optName = "trace-primops", updateCfg = \cfg _ -> cfg {tracePrimops = True, rtsLibs = debugLib : rtsLibs cfg},- info = "Turn on run-time tracing of primops. Also turned on by "- ++ "-debug."},+ info = "Turn on run-time tracing of primops."}, ArgSpec { optName = "verbose", updateCfg = \cfg _ -> cfg {verbose = True}, info = "Display even the most obnoxious warnings."},@@ -116,7 +115,7 @@ -- | Enable all optimizations, both safe and unsafe. optAllUnsafe :: Config -> [String] -> Config-optAllUnsafe = optAllSafe ||| unsafeMath+optAllUnsafe = optAllSafe ||| unsafeMath ||| enableWholeProgramOpts -- | Enable all safe optimizations. optAllSafe :: Config -> [String] -> Config
− src/Control/Shell.hs
@@ -1,290 +0,0 @@-{-# 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,- 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 /= ".."]---- | 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/Haste/Environment.hs view
@@ -11,6 +11,7 @@ import Foreign.C.Types (CIntPtr) import System.Environment.Executable import System.Directory+import System.Exit import Paths_haste_compiler -- | The directory where the currently residing binary lives.@@ -58,12 +59,15 @@ pkgLibDir :: FilePath pkgLibDir = hasteInstDir </> "lib" --- | Run a process and wait for its completion.+-- | Run a process and wait for its completion. Terminate with an error code+-- if the process did not exit cleanly. runAndWait :: FilePath -> [String] -> Maybe FilePath -> IO () runAndWait file args workDir = do h <- runProcess file args workDir Nothing Nothing Nothing Nothing- _ <- waitForProcess h- return ()+ ec <- waitForProcess h+ case ec of+ ExitFailure _ -> exitFailure+ _ -> return () {- -- | Find an executable.
src/Haste/Version.hs view
@@ -10,7 +10,7 @@ import Haste.Environment (hasteDir) hasteVersion :: Version-hasteVersion = Version [0, 2, 10] []+hasteVersion = Version [0, 2, 11] [] ghcVersion :: String ghcVersion = cProjectVersion
src/Main.hs view
@@ -111,7 +111,7 @@ -- | The main compiler driver. compiler :: [String] -> IO () compiler cmdargs = do- let cmdargs' | "-debug" `elem` cmdargs = "--trace-primops":cmdargs+ let cmdargs' | "-debug" `elem` cmdargs = "--debug":"--trace-primops":cmdargs | otherwise = cmdargs argRes = handleArgs defConfig argSpecs cmdargs' usedGhcMode = if "-c" `elem` cmdargs then OneShot else CompManager
src/haste-boot.hs view
@@ -10,17 +10,18 @@ import Codec.Compression.BZip import Codec.Archive.Tar import System.Environment (getArgs)-import System.IO.Temp+import System.Exit import Control.Monad import qualified Codec.Archive.Zip as Zip import Haste.Environment import Haste.Version import Control.Shell import Data.Char (isDigit)+import Control.Monad.IO.Class (liftIO) -downloadFile :: String -> IO (Either String BS.ByteString)+downloadFile :: String -> Shell BS.ByteString downloadFile f = do- (_, rsp) <- Network.Browser.browse $ do+ (_, rsp) <- liftIO $ Network.Browser.browse $ do setAllowRedirects True request $ Request { rqURI = fromJust $ parseURI f,@@ -29,13 +30,14 @@ rqBody = BS.empty } case rspCode rsp of - (2, _, _) -> return $ Right $ rspBody rsp- _ -> return $ Left $ rspReason rsp+ (2, _, _) -> return $ rspBody rsp+ _ -> fail $ "Failed to download " ++ f ++ ": " ++ rspReason rsp data Cfg = Cfg { getLibs :: Bool, getClosure :: Bool,- useLocalLibs :: Bool+ useLocalLibs :: Bool,+ tracePrimops :: Bool } main :: IO ()@@ -51,113 +53,109 @@ then False else forceBoot || needsReboot local = elem "--local" args+ trace = elem "--trace-primops" args cfg = Cfg { getLibs = libs, getClosure = closure,- useLocalLibs = local+ useLocalLibs = local,+ tracePrimops = trace } when (needsReboot || forceBoot) $ do- if local- then bootHaste cfg "."- else withSystemTempDirectory "haste" $ bootHaste cfg+ res <- shell $ if local+ then bootHaste cfg "."+ else withTempDirectory "haste" $ bootHaste cfg+ case res of+ Right _ -> return ()+ Left err -> putStrLn err >> exitFailure -bootHaste :: Cfg -> FilePath -> IO ()-bootHaste cfg tmpdir = do- setCurrentDirectory tmpdir+bootHaste :: Cfg -> FilePath -> Shell ()+bootHaste cfg tmpdir = inDirectory tmpdir $ do when (getLibs cfg) $ do when (not $ useLocalLibs cfg) $ do fetchLibs tmpdir- exists <- doesDirectoryExist hasteInstDir- when exists $ removeDirectoryRecursive hasteInstDir- exists <- doesDirectoryExist jsmodDir- when exists $ removeDirectoryRecursive jsmodDir- exists <- doesDirectoryExist pkgDir- when exists $ removeDirectoryRecursive pkgDir- buildLibs+ exists <- isDirectory hasteInstDir+ when exists $ rmdir hasteInstDir+ exists <- isDirectory jsmodDir+ when exists $ rmdir jsmodDir+ exists <- isDirectory pkgDir+ when exists $ rmdir pkgDir+ buildLibs cfg when (getClosure cfg) $ do installClosure- Prelude.writeFile bootFile (show bootVersion)+ file bootFile (show bootVersion) -- | Fetch the Haste base libs.-fetchLibs :: FilePath -> IO ()+fetchLibs :: FilePath -> Shell () 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+ echo "Downloading base libs from ekblad.cc"+ file <- downloadFile $ mkUrl hasteVersion+ liftIO . unpack tmpdir . read . decompress $ file where mkUrl v = "http://ekblad.cc/haste-libs/haste-libs-" ++ showVersion v ++ ".tar.bz2" -- | Fetch and install the Closure compiler.-installClosure :: IO ()+installClosure :: Shell () 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'+ echo "Downloading Google Closure compiler..."+ downloadAndUnpackClosure `orElse` do+ echo "Couldn't install Closure compiler; continuing without."+ where+ downloadAndUnpackClosure = do+ file <- downloadFile closureURI+ let cloArch = Zip.toArchive file case Zip.findEntryByPath "compiler.jar" cloArch of Just compiler ->- BS.writeFile closureCompiler- (Zip.fromEntry compiler)+ liftIO $ BS.writeFile closureCompiler (Zip.fromEntry compiler) _ ->- putStrLn "Couldn't unpack Closure compiler; continuing without."- where+ fail "Unable to unpack Closure compiler" closureURI = "http://dl.google.com/closure-compiler/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_ hastePkgBinary ["update", "libraries" </> "rts.pkg"] ""+buildLibs :: Cfg -> Shell ()+buildLibs cfg = do+ -- Set up dirs and copy includes+ mkdir True $ pkgLibDir+ cpDir "include" hasteDir+ run_ hastePkgBinary ["update", "libraries" </> "rts.pkg"] ""+ + inDirectory "libraries" $ do+ -- Install ghc-prim+ inDirectory "ghc-prim" $ do+ hasteInst ["configure"]+ hasteInst $ ["build", "--install-jsmods"] ++ ghcOpts+ run_ hasteInstHisBinary ["ghc-prim-0.3.0.0", "dist" </> "build"] ""+ run_ hastePkgBinary ["update", "packageconfig"] "" - inDirectory "libraries" $ do- -- Install ghc-prim- inDirectory "ghc-prim" $ do- hasteInst ["configure"]- hasteInst ["build", "--install-jsmods", ghcOpts]- run_ hasteInstHisBinary ["ghc-prim-0.3.0.0", "dist" </> "build"] ""- run_ hastePkgBinary ["update", "packageconfig"] ""- - -- Install integer-gmp; double install shouldn't be needed anymore.- run_ hasteCopyPkgBinary ["Cabal"] ""- inDirectory "integer-gmp" $ do- 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_ hasteInstHisBinary [base, "dist" </> "build"] ""- run_ hasteCopyPkgBinary [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 ()+ -- Install integer-gmp; double install shouldn't be needed anymore.+ run_ hasteCopyPkgBinary ["Cabal"] ""+ inDirectory "integer-gmp" $ do+ 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_ hasteInstHisBinary [base, "dist" </> "build"] ""+ run_ hasteCopyPkgBinary [base, pkgdb] ""+ + -- Install array, fursuit and haste-lib+ forM_ ["array", "fursuit", "haste-lib"] $ \pkg -> do+ inDirectory pkg $ hasteInst ("install" : ghcOpts) where- ghcOpts =- "--ghc-options=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ show hostWordSize+ ghcOpts = concat [+ if tracePrimops cfg then ["--ghc-option=-debug"] else [],+ ["--ghc-option=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ show hostWordSize]+ ] hasteInst args = run_ hasteInstBinary ("--unbooted" : args) ""