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