haste-compiler 0.4.4.4 → 0.5.0

raw patch · 86 files changed

+6474/−2983 lines, 86 filesdep +Cabaldep +bin-package-dbdep +ghc-simpledep ~basedep ~directorydep ~ghcsetup-changednew-component:exe:haste-cabalPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, bin-package-db, ghc-simple, terminfo, unix

Dependency ranges changed: base, directory, ghc, process

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Setup.hs +71/−35
• haste-compiler.cabal +85/−40
• lib/Foreign.js +75/−0
• lib/StableName.js +10/−5
• lib/endian.js +29/−0
• lib/floatdecode.js +32/−0
• lib/jsflow.js +5/−0
• lib/jsstring.js +48/−0
• lib/rts.js +51/−76
• lib/stdlib.js +18/−129
• libraries/haste-lib/src/Haste.hs +7/−6
• libraries/haste-lib/src/Haste/Ajax.hs +32/−67
• libraries/haste-lib/src/Haste/Any.hs +350/−0
• libraries/haste-lib/src/Haste/App.hs +4/−8
• libraries/haste-lib/src/Haste/App/Client.hs +9/−8
• libraries/haste-lib/src/Haste/App/Concurrent.hs +1/−0
• libraries/haste-lib/src/Haste/App/Events.hs +0/−40
• libraries/haste-lib/src/Haste/App/Monad.hs +13/−23
• libraries/haste-lib/src/Haste/App/Protocol.hs +3/−1
• libraries/haste-lib/src/Haste/Audio.hs +245/−0
• libraries/haste-lib/src/Haste/Audio/Events.hs +34/−0
• libraries/haste-lib/src/Haste/Binary.hs +47/−18
• libraries/haste-lib/src/Haste/Binary/Get.hs +53/−40
• libraries/haste-lib/src/Haste/Binary/Put.hs +40/−20
• libraries/haste-lib/src/Haste/Binary/Types.hs +27/−12
• libraries/haste-lib/src/Haste/Callback.hs +0/−158
• libraries/haste-lib/src/Haste/Compiler.hs +25/−21
• libraries/haste-lib/src/Haste/Compiler/Flags.hs +25/−17
• libraries/haste-lib/src/Haste/Concurrent.hs +3/−8
• libraries/haste-lib/src/Haste/Concurrent/Ajax.hs +15/−40
• libraries/haste-lib/src/Haste/Concurrent/Monad.hs +6/−4
• libraries/haste-lib/src/Haste/DOM.hs +60/−289
• libraries/haste-lib/src/Haste/DOM/Core.hs +226/−0
• libraries/haste-lib/src/Haste/DOM/JSString.hs +213/−0
• libraries/haste-lib/src/Haste/Events.hs +11/−0
• libraries/haste-lib/src/Haste/Events/BasicEvents.hs +24/−0
• libraries/haste-lib/src/Haste/Events/Core.hs +99/−0
• libraries/haste-lib/src/Haste/Events/KeyEvents.hs +56/−0
• libraries/haste-lib/src/Haste/Events/MouseEvents.hs +61/−0
• libraries/haste-lib/src/Haste/Foreign.hs +132/−314
• libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs +29/−0
• libraries/haste-lib/src/Haste/Graphics/Canvas.hs +66/−67
• libraries/haste-lib/src/Haste/Hash.hs +11/−23
• libraries/haste-lib/src/Haste/JSON.hs +27/−13
• libraries/haste-lib/src/Haste/JSString.hs +318/−0
• libraries/haste-lib/src/Haste/JSType.hs +19/−3
• libraries/haste-lib/src/Haste/LocalStorage.hs +10/−8
• libraries/haste-lib/src/Haste/Object.hs +78/−0
• libraries/haste-lib/src/Haste/Parsing.hs +4/−0
• libraries/haste-lib/src/Haste/Performance.hs +16/−0
• libraries/haste-lib/src/Haste/Prim.hs +36/−18
• libraries/haste-lib/src/Haste/Random.hs +4/−4
• libraries/haste-lib/src/Haste/Serialize.hs +3/−1
• libraries/haste-lib/src/Haste/Timer.hs +47/−0
• libraries/haste-lib/src/Haste/WebSockets.hs +22/−49
• src/Data/JSTarget.hs +2/−2
• src/Data/JSTarget/AST.hs +75/−93
• src/Data/JSTarget/Binary.hs +43/−50
• src/Data/JSTarget/Constructors.hs +91/−74
• src/Data/JSTarget/Optimize.hs +437/−190
• src/Data/JSTarget/PP.hs +20/−23
• src/Data/JSTarget/Print.hs +47/−40
• src/Data/JSTarget/Traversal.hs +216/−210
• src/Haste/Builtins.hs +1/−0
• src/Haste/CodeGen.hs +154/−148
• src/Haste/Config.hs +37/−10
• src/Haste/Environment.hs +50/−24
• src/Haste/Errors.hs +2/−1
• src/Haste/GHCPaths.hs +0/−7
• src/Haste/Linker.hs +33/−26
• src/Haste/Module.hs +3/−1
• src/Haste/Monad.hs +64/−23
• src/Haste/Opts.hs +31/−9
• src/Haste/PrimOps.hs +13/−17
• src/Haste/Version.hs +4/−10
• src/Main.hs +0/−267
• src/haste-boot.hs +111/−65
• src/haste-cabal.hs +59/−0
• src/haste-cat.hs +7/−4
• src/haste-copy-pkg.hs +0/−4
• src/haste-inst.hs +0/−47
• src/haste-pkg.hs +0/−72
• src/hastec.hs +203/−0
• utils/haste-pkg/CRT_noglob.c +4/−0
• utils/haste-pkg/haste-pkg.hs +1831/−0

@@ -1,4 +1,4 @@-Copyright Anton Ekblad 2012-2014+Copyright Anton Ekblad 2012-2015  All rights reserved. 

@@ -7,45 +7,81 @@ import System.Directory import System.FilePath import GHC.Paths+import Data.Version -main = defaultMainWithHooks $ simpleUserHooks {-    postBuild = \args buildflags pkgdesc buildinfo -> do-       when (buildinfo `has` "portable" ||-             buildinfo `has` "portable-compiler") $ do-         -- Figure out paths-         let dirname = "haste-compiler"-             exes = [ exeName exe-                    | exe <- executables pkgdesc]-             builddir = buildDir buildinfo-             outdir = dirname-             datadir = dataDir $ localPkgDescr buildinfo-             jsfiles = dataFiles $ localPkgDescr buildinfo-             hastedirfile = ".hastedir" -- does Haste "own" this directory?+showBootVersion :: Version -> LocalBuildInfo -> String+showBootVersion ver lbi =+    "haste-" ++ showVersion ver ++ "_ghc-" ++ ghcver+  where+    ghcver =+      case compilerId $ compiler lbi of+        CompilerId GHC ver -> showVersion ver+        _                  -> error "Haste only supports building with GHC!"++portablePostBuild :: PackageDescription -> LocalBuildInfo -> IO ()+portablePostBuild pkgdesc buildinfo = do+  -- Figure out paths+  let dirname = "haste-compiler"+      exes = [ exeName exe+             | exe <- executables pkgdesc]+      builddir = buildDir buildinfo+      outdir = dirname+      datadir = dataDir $ localPkgDescr buildinfo+      jsfiles = dataFiles $ localPkgDescr buildinfo+      hastedirfile = ".hastedir" -- does Haste "own" this directory?          -         dirExists <- doesDirectoryExist outdir-         isHasteDir <- doesFileExist (outdir </> hastedirfile)-         when (dirExists && not isHasteDir) $-           error $ "The output directory " ++ outdir ++ " already exists, "-                 ++ "and doesn't seem to be a Haste installation."-         when (dirExists && isHasteDir) $-           removeDirectoryRecursive outdir+  dirExists <- doesDirectoryExist outdir+  isHasteDir <- doesFileExist (outdir </> hastedirfile)+  when (dirExists && not isHasteDir) $+    error $ "The output directory " ++ outdir ++ " already exists, "+            ++ "and doesn't seem to be a Haste installation." -         -- Create directory and mark as ours-         createDirectoryIfMissing True (outdir </> "js")-         createDirectoryIfMissing True (outdir </> "bin")-         writeFile (outdir </> ".hastedir") ""+  when (dirExists && isHasteDir) $+    removeDirectoryRecursive outdir -         -- Copy executables-         forM_ exes $ \exe -> do-           exists <- doesFileExist $ builddir </> exe </> exe-           if exists-             then copyFile (builddir </> exe </> exe) (outdir </> "bin" </> exe)-             else copyFile (builddir </> exe </> exe <.> "exe")-                           (outdir </> "bin" </> exe <.> "exe")-         -         -- Copy libs-         forM_ jsfiles $ \js -> do-           copyFile (datadir </> js) (outdir </> "js" </> js)+  -- Create directory and mark as ours+  createDirectoryIfMissing True (outdir </> "js")+  createDirectoryIfMissing True (outdir </> "bin")+  writeFile (outdir </> ".hastedir") ""++  -- Copy settings and tools, except on Windows where we need a working+  -- Haskell Platform anyway.+#ifndef mingw32_HOST_OS+  copyGhcSettings outdir+#endif++  -- Copy executables+  forM_ exes $ \exe -> do+    exists <- doesFileExist $ builddir </> exe </> exe+    if exists+      then copyFile (builddir </> exe </> exe)+                    (outdir </> "bin" </> exe)+      else copyFile (builddir </> exe </> exe <.> "exe")+                    (outdir </> "bin" </> exe <.> "exe")++  -- Copy libs+  forM_ jsfiles $ \js -> do+    copyFile (datadir </> js) (outdir </> "js" </> js)++cabalPostBuild :: PackageDescription -> LocalBuildInfo -> IO ()+cabalPostBuild pkgdesc lbi = do+  appdir <- getAppUserDataDirectory "haste"+  let dest = appdir </> showBootVersion (pkgVersion $ package pkgdesc) lbi+  createDirectoryIfMissing True dest+  copyGhcSettings dest++-- | Copy GHC settings and utils into the given directory.+copyGhcSettings :: FilePath -> IO ()+copyGhcSettings dest = do+  copyFile (libdir </> "settings") (dest </> "settings")+  copyFile (libdir </> "platformConstants") (dest </> "platformConstants")+  copyFile (libdir </> "unlit") (dest </> "unlit")++main = defaultMainWithHooks $ simpleUserHooks {+    postBuild = \_ _ pkgdesc buildinfo -> do+      if (buildinfo `has` "portable" || buildinfo `has` "portable-compiler")+        then portablePostBuild pkgdesc buildinfo+        else cabalPostBuild pkgdesc buildinfo   }  has :: LocalBuildInfo -> String -> Bool

@@ -1,13 +1,13 @@ Name:           haste-compiler-Version:        0.4.4.4+Version:        0.5.0 License:        BSD3 License-File:   LICENSE Synopsis:       Haskell To ECMAScript compiler Description:    This package provides a featureful compiler from Haskell to-                Javascript. It generates small, fast code, makes use of-                standard Haskell libraries, integrates with Cabal, supports-                most GHC extensions and works on Windows, Linux and OSX.-                Bug reports are highly appreciated.+                JavaScript based on GHC. It generates small, fast code, makes+                use of standard Haskell libraries, integrates with Cabal,+                supports most GHC extensions and works on Windows, Linux and+                OSX. Category:       Javascript, Compiler, Web Cabal-Version:  >= 1.10 Build-Type:     Custom@@ -36,6 +36,11 @@     Canvas.js     Handle.js     Weak.js+    endian.js+    floatdecode.js+    jsflow.js+    jsstring.js+    Foreign.js  Flag portable     Description:@@ -103,7 +108,7 @@     Build-Depends:         base < 5,         ghc-prim,-        ghc >= 7.4,+        ghc >= 7.8 && < 7.10,         mtl,         binary,         containers,@@ -116,9 +121,10 @@         system-fileio,         shellmate >= 0.1.5,         either,-        directory+        directory,+        ghc-simple >= 0.1.2.1     Main-Is:-        Main.hs+        hastec.hs     Other-Modules:         Haste         Haste.Args@@ -145,10 +151,10 @@         Data.JSTarget.Traversal     default-language: Haskell98 -Executable haste-inst+Executable haste-cabal     if flag(only-library)         buildable: False-    Main-Is: haste-inst.hs+    Main-Is: haste-cabal.hs     Hs-Source-Dirs: src     if flag(portable)         CPP-Options: -DPORTABLE@@ -167,27 +173,44 @@     default-language: Haskell98  Executable haste-pkg+    Default-Language: Haskell2010+    Main-Is: haste-pkg.hs+    Other-Modules:+    Other-Extensions: CPP+    Hs-Source-Dirs:+      src+      utils/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           if os(linux)             GHC-Options: -static -optl-static -optl-pthread-    Build-Depends:-        base < 5,-        shellmate,-        ghc-paths,-        ghc,-        process,-        directory-    default-language: Haskell98 +    Build-Depends: base       >= 4   && < 5,+                   directory  >= 1   && < 1.3,+                   process    >= 1   && < 1.3,+                   Cabal,+                   containers,+                   filepath,+                   binary,+                   bin-package-db,+                   bytestring,+                   shellmate,+                   ghc+    if !os(windows)+        Build-Depends: unix,+                       terminfo+    if os(windows)+        c-sources: utils/haste-pkg/CRT_noglob.c+ Executable haste-install-his     if flag(only-library)         buildable: False@@ -231,6 +254,12 @@     Hs-Source-Dirs: src     if flag(portable)         CPP-Options: -DPORTABLE+    if flag(static)+        if os(windows)+          GHC-Options: -static -optl-static+        else+          if os(linux)+            GHC-Options: -static -optl-static -optl-pthread     Build-Depends:         base < 5,         shellmate >= 0.1.5,@@ -243,7 +272,9 @@         array,         random,         data-default,-        directory+        mtl,+        directory,+        utf8-string     default-language: Haskell98  Library@@ -251,45 +282,59 @@     GHC-Options: -Wall -O2     Exposed-Modules:         Haste+        Haste.Ajax         Haste.App         Haste.App.Concurrent+        Haste.Audio         Haste.Binary         Haste.Compiler-        Haste.JSON-        Haste.Ajax-        Haste.DOM-        Haste.Prim         Haste.Concurrent-        Haste.Graphics.Canvas+        Haste.DOM+        Haste.DOM.JSString+        Haste.Events         Haste.Foreign-        Haste.Serialize+        Haste.Graphics.AnimationFrame+        Haste.Graphics.Canvas+        Haste.JSON+        Haste.JSString+        Haste.LocalStorage+        Haste.Object         Haste.Parsing+        Haste.Performance+        Haste.Prim+        Haste.Serialize         Haste.WebSockets-        Haste.LocalStorage     Other-Modules:-        Haste.JSType-        Haste.Callback-        Haste.Compiler.Flags-        Haste.Version-        Haste.Environment-        Haste.GHCPaths-        Paths_haste_compiler-        Haste.Hash-        Haste.Random-        Haste.Concurrent.Monad-        Haste.Concurrent.Ajax+        Haste.Any         Haste.App.Client-        Haste.App.Events         Haste.App.Monad         Haste.App.Protocol+        Haste.Audio.Events         Haste.Binary.Get         Haste.Binary.Put         Haste.Binary.Types+        Haste.Compiler.Flags+        Haste.Concurrent.Monad+        Haste.Concurrent.Ajax+        Haste.DOM.Core+        Haste.Environment+        Haste.Events.BasicEvents+        Haste.Events.Core+        Haste.Events.KeyEvents+        Haste.Events.MouseEvents+        Haste.GHCPaths+        Haste.Hash+        Haste.JSType+        Haste.Random+        Haste.Timer+        Haste.Version+        Paths_haste_compiler     Build-Depends:         transformers,         monads-tf,         containers,         base < 5,+        ghc-prim,         random,         binary,         data-binary-ieee754,

@@ -0,0 +1,75 @@+/* For foreign import ccall "wrapper" */+function createAdjustor(args, f, a, b) {+    return function(){+        var x = f.apply(null, arguments);+        while(x instanceof F) {x = x.f();}+        return x;+    };+}++var __apply = function(f,as) {+    var arr = [];+    for(; as[0] === 1; as = as[2]) {+        arr.push(as[1]);+    }+    arr.reverse();+    return f.apply(null, arr);+}+var __app0 = function(f) {return f();}+var __app1 = function(f,a) {return f(a);}+var __app2 = function(f,a,b) {return f(a,b);}+var __app3 = function(f,a,b,c) {return f(a,b,c);}+var __app4 = function(f,a,b,c,d) {return f(a,b,c,d);}+var __app5 = function(f,a,b,c,d,e) {return f(a,b,c,d,e);}+var __jsNull = function() {return null;}+var __jsTrue = function() {return true;}+var __jsFalse = function() {return false;}+var __eq = function(a,b) {return a===b;}+var __createJSFunc = function(arity, f){+    if(f instanceof Function && arity === f.length) {+        return (function() {+            var x = f.apply(null,arguments);+            if(x instanceof T) {+                if(x.f !== __blackhole) {+                    var ff = x.f;+                    x.f = __blackhole;+                    return x.x = ff();+                }+                return x.x;+            } else {+                while(x instanceof F) {+                    x = x.f();+                }+                return E(x);+            }+        });+    } else {+        return (function(){+            var as = Array.prototype.slice.call(arguments);+            as.push(0);+            return E(B(A(f,as)));+        });+    }+}+++function __arr2lst(elem,arr) {+    if(elem >= arr.length) {+        return [0];+    }+    return [1, arr[elem],new T(function(){return __arr2lst(elem+1,arr);})]+}++function __lst2arr(xs) {+    var arr = [];+    xs = E(xs);+    for(;xs[0] === 1; xs = E(xs[2])) {+        arr.push(E(xs[1]));+    }+    return arr;+}++var __new = function() {return ({});}+var __set = function(o,k,v) {o[k]=v;}+var __get = function(o,k) {return o[k];}+var __has = function(o,k) {return o[k]!==undefined;}

@@ -7,15 +7,20 @@ // as its stable name.  var __next_stable_name = 1;+var __stable_table;  function makeStableName(x) {-    if(!x.stableName) {-        x.stableName = __next_stable_name;-        __next_stable_name += 1;+    if(x instanceof Object) {+        if(!x.stableName) {+            x.stableName = __next_stable_name;+            __next_stable_name += 1;+        }+        return {type: 'obj', name: x.stableName};+    } else {+        return {type: 'prim', name: Number(x)};     }-    return x.stableName; }  function eqStableName(x, y) {-    return (x == y) ? 1 : 0;+    return (x.type == y.type && x.name == y.name) ? 1 : 0; }

@@ -0,0 +1,29 @@+// Create a little endian ArrayBuffer representation of something.+function toABHost(v, n, x) {+    var a = new ArrayBuffer(n);+    new window[v](a)[0] = x;+    return a;+}++function toABSwap(v, n, x) {+    var a = new ArrayBuffer(n);+    new window[v](a)[0] = x;+    var bs = new Uint8Array(a);+    for(var i = 0, j = n-1; i < j; ++i, --j) {+        var tmp = bs[i];+        bs[i] = bs[j];+        bs[j] = tmp;+    }+    return a;+}++window['toABle'] = toABHost;+window['toABbe'] = toABSwap;++// Swap byte order if host is not little endian.+var buffer = new ArrayBuffer(2);+new DataView(buffer).setInt16(0, 256, true);+if(new Int16Array(buffer)[0] !== 256) {+    window['toABle'] = toABSwap;+    window['toABbe'] = toABHost;+}

@@ -0,0 +1,32 @@+// Scratch space for byte arrays.+var rts_scratchBuf = new ArrayBuffer(8);+var rts_scratchW32 = new Uint32Array(rts_scratchBuf);+var rts_scratchFloat = new Float32Array(rts_scratchBuf);+var rts_scratchDouble = new Float64Array(rts_scratchBuf);++function decodeFloat(x) {+    rts_scratchFloat[0] = x;+    var sign = x < 0 ? -1 : 1;+    var exp = ((rts_scratchW32[0] >> 23) & 0xff) - 150;+    var man = rts_scratchW32[0] & 0x7fffff;+    if(exp === 0) {+        ++exp;+    } else {+        man |= (1 << 23);+    }+    return [0, sign*man, exp];+}++function decodeDouble(x) {+    rts_scratchDouble[0] = x;+    var sign = x < 0 ? -1 : 1;+    var manHigh = rts_scratchW32[1] & 0xfffff;+    var manLow = rts_scratchW32[0];+    var exp = ((rts_scratchW32[1] >> 20) & 0x7ff) - 1075;+    if(exp === 0) {+        ++exp;+    } else {+        manHigh |= (1 << 20);+    }+    return [0, sign, manHigh, manLow, exp];+}

@@ -0,0 +1,5 @@+/* JSFlow support functions. */+console = {+    'log': lprint,+    'warn': lprint+  };

@@ -0,0 +1,48 @@+/* Utility functions for working with JSStrings. */++var _jss_singleton = String.fromCharCode;++function _jss_cons(c,s) {return String.fromCharCode(c)+s;}+function _jss_snoc(s,c) {return s+String.fromCharCode(c);}+function _jss_append(a,b) {return a+b;}+function _jss_len(s) {return s.length;}+function _jss_index(s,i) {return s.charCodeAt(i);}+function _jss_drop(s,i) {return s.substr(i);}+function _jss_substr(s,a,b) {return s.substr(a,b);}+function _jss_take(n,s) {return s.substr(0,n);}+// TODO: incorrect for some unusual characters.+function _jss_rev(s) {return s.split("").reverse().join("");}++function _jss_map(f,s) {+    f = E(f);+    var s2 = '';+    for(var i in s) {+        s2 += String.fromCharCode(E(f(s.charCodeAt(i))));+    }+    return s2;+}++function _jss_foldl(f,x,s) {+    f = E(f);+    for(var i in s) {+        x = A(f,[x,s.charCodeAt(i)]);+    }+    return x;+}++function _jss_re_match(s,re) {return s.search(re)>=0;}+function _jss_re_compile(re,fs) {return new RegExp(re,fs);}+function _jss_re_replace(s,re,rep) {return s.replace(re,rep);}++function _jss_re_find(re,s) {+    var a = s.match(re);+    return a ? mklst(a) : [0];+}++function mklst(arr) {+    var l = [0], len = arr.length-1;+    for(var i = 0; i <= len; ++i) {+        l = [1,arr[len-i],l];+    }+    return l;+}

@@ -12,58 +12,66 @@     } } +/* Hint to optimizer that an imported symbol is strict. */+function __strict(x) {return x}++// A tailcall. function F(f) {     this.f = f; } +// A partially applied function. Invariant: members are never thunks.+function PAP(f, args) {+    this.f = f;+    this.args = args;+    this.arity = f.length - args.length;+}+ // Special object used for blackholing. var __blackhole = {};  // Used to indicate that an object is updatable. var __updatable = {}; -/* Apply-   Applies the function f to the arguments args. If the application is under--   saturated, a closure is returned, awaiting further arguments. If it is over--   saturated, the function is fully applied, and the result (assumed to be a-   function) is then applied to the remaining arguments.+/* Generic apply.+   Applies a function *or* a partial application object to a list of arguments.+   See https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/HaskellExecution/FunctionCalls+   for more information. */ function A(f, args) {-    if(f instanceof T) {+    while(true) {         f = E(f);-    }-    // Closure does some funny stuff with functions that occasionally-    // results in non-functions getting applied, so we have to deal with-    // it.-    if(!(f instanceof Function)) {-        f = B(f);-        if(!(f instanceof Function)) {+        if(f instanceof F) {+            f = E(B(f));+        }+        if(f instanceof PAP) {+            // f is a partial application+            if(args.length == f.arity) {+                // Saturated application+                return f.f.apply(null, f.args.concat(args));+            } else if(args.length < f.arity) {+                // Application is still unsaturated+                return new PAP(f.f, f.args.concat(args));+            } else {+                // Application is oversaturated; +                var f2 = f.f.apply(null, f.args.concat(args.slice(0, f.arity)));+                args = args.slice(f.arity);+                f = B(f2);+            }+        } else if(f instanceof Function) {+            if(args.length == f.length) {+                return f.apply(null, args);+            } else if(args.length < f.length) {+                return new PAP(f, args);+            } else {+                var f2 = f.apply(null, args.slice(0, f.length));+                args = args.slice(f.length);+                f = B(f2);+            }+        } else {             return f;         }     }--    if(f.arity === undefined) {-        f.arity = f.length;-    }-    if(args.length === f.arity) {-        switch(f.arity) {-            case 0:  return f();-            case 1:  return f(args[0]);-            default: return f.apply(null, args);-        }-    } else if(args.length > f.arity) {-        switch(f.arity) {-            case 0:  return f();-            case 1:  return A(f(args.shift()), args);-            default: return A(f.apply(null, args.splice(0, f.arity)), args);-        }-    } else {-        var g = function() {-            return A(f, args.concat(Array.prototype.slice.call(arguments)));-        };-        g.arity = f.arity - args.length;-        return g;-    } }  /* Eval@@ -114,7 +122,7 @@    We need to be able to use throw as an exception so we wrap it in a function. */ function die(err) {-    throw err;+    throw E(err); }  function quot(a, b) {@@ -162,39 +170,6 @@     return (Math.exp(arg) + Math.exp(-arg)) / 2; } -// Scratch space for byte arrays.-var rts_scratchBuf = new ArrayBuffer(8);-var rts_scratchW32 = new Uint32Array(rts_scratchBuf);-var rts_scratchFloat = new Float32Array(rts_scratchBuf);-var rts_scratchDouble = new Float64Array(rts_scratchBuf);--function decodeFloat(x) {-    rts_scratchFloat[0] = x;-    var sign = x < 0 ? -1 : 1;-    var exp = ((rts_scratchW32[0] >> 23) & 0xff) - 150;-    var man = rts_scratchW32[0] & 0x7fffff;-    if(exp === 0) {-        ++exp;-    } else {-        man |= (1 << 23);-    }-    return [0, sign*man, exp];-}--function decodeDouble(x) {-    rts_scratchDouble[0] = x;-    var sign = x < 0 ? -1 : 1;-    var manHigh = rts_scratchW32[1] & 0xfffff;-    var manLow = rts_scratchW32[0];-    var exp = ((rts_scratchW32[1] >> 20) & 0x7ff) - 1075;-    if(exp === 0) {-        ++exp;-    } else {-        manHigh |= (1 << 20);-    }-    return [0, sign, manHigh, manLow, exp];-}- function isFloatFinite(x) {     return isFinite(x); }@@ -215,7 +190,7 @@ function unFoldrCStr(str, f, z) {     var acc = z;     for(var i = str.length-1; i >= 0; --i) {-        acc = B(A(f, [[0, str.charCodeAt(i)], acc]));+        acc = B(A(f, [str.charCodeAt(i), acc]));     }     return acc; }@@ -225,7 +200,7 @@     if(i >= str.length) {         return E(chrs);     } else {-        return [1,[0,str.charCodeAt(i)],new T(function() {+        return [1,str.charCodeAt(i),new T(function() {             return unAppCStr(str,chrs,i+1);         })];     }@@ -240,7 +215,7 @@ function toJSStr(hsstr) {     var s = '';     for(var str = E(hsstr); str[0] == 1; str = E(str[2])) {-        s += String.fromCharCode(E(str[1])[1]);+        s += String.fromCharCode(E(str[1]));     }     return s; }@@ -296,11 +271,11 @@  function strOrd(a, b) {     if(a < b) {-        return [0];+        return 0;     } else if(a == b) {-        return [1];+        return 1;     }-    return [2];+    return 2; }  function jsCatch(act, handler) {

@@ -40,7 +40,7 @@     return val == Math.round(val) ? ret + '.0' : ret; } -function jsGetMouseCoords(e) {+window['jsGetMouseCoords'] = function jsGetMouseCoords(e) {     var posx = 0;     var posy = 0;     if (!e) var e = window.event;@@ -58,76 +58,6 @@ 	    posy - (e.currentTarget.offsetTop || 0)]; } -function jsSetCB(elem, evt, cb) {-    // Count return press in single line text box as a change event.-    if(evt == 'change' && elem.type.toLowerCase() == 'text') {-        setCB(elem, 'keyup', function(k) {-            if(k == '\n'.charCodeAt(0)) {-                B(A(cb,[[0,k.keyCode],0]));-            }-        });-    }--    var fun;-    switch(evt) {-    case 'click':-    case 'dblclick':-    case 'mouseup':-    case 'mousedown':-        fun = function(x) {-            var mpos = jsGetMouseCoords(x);-            var mx = [0,mpos[0]];-            var my = [0,mpos[1]];-            B(A(cb,[[0,x.button],[0,mx,my],0]));-        };-        break;-    case 'mousemove':-    case 'mouseover':-        fun = function(x) {-            var mpos = jsGetMouseCoords(x);-            var mx = [0,mpos[0]];-            var my = [0,mpos[1]];-            B(A(cb,[[0,mx,my],0]));-        };-        break;-    case 'keypress':-    case 'keyup':-    case 'keydown':-        fun = function(x) {B(A(cb,[[0,x.keyCode],0]));};-        break;-    case 'wheel':-        fun = function(x) {-            var mpos = jsGetMouseCoords(x);-            var mx = [0,mpos[0]];-            var my = [0,mpos[1]];-            var mdx = [0,x.deltaX];-            var mdy = [0,x.deltaY];-            var mdz = [0,x.deltaZ];-            B(A(cb,[[0,mx,my],[0,mdx,mdy,mdz],0]));-        };-        break;-    default:-        fun = function() {B(A(cb,[0]));};-        break;-    }-    return setCB(elem, evt, fun);-}--function setCB(elem, evt, cb) {-    if(elem.addEventListener) {-        elem.addEventListener(evt, cb, false);-        return true;-    } else if(elem.attachEvent) {-        elem.attachEvent('on'+evt, cb);-        return true;-    }-    return false;-}--function jsSetTimeout(msecs, cb) {-    window.setTimeout(function() {B(A(cb,[0]));}, msecs);-}- function jsGet(elem, prop) {     return elem[prop].toString(); }@@ -169,7 +99,7 @@ function jsFind(elem) {     var e = document.getElementById(elem)     if(e) {-        return [1,[0,e]];+        return [1,e];     }     return [0]; }@@ -179,7 +109,7 @@     var els = [0];      for (var i = es.length-1; i >= 0; --i) {-        els = [1, [0, es[i]], els];+        els = [1, es[i], els];     }     return els; }@@ -194,7 +124,7 @@     nl = elem.querySelectorAll(query);      for (var i = nl.length-1; i >= 0; --i) {-        els = [1, [0, nl[i]], els];+        els = [1, nl[i], els];     }      return els;@@ -212,7 +142,7 @@     elem = elem.previousSibling;     while(elem) {         if(typeof elem.tagName != 'undefined') {-            return [1,[0,elem]];+            return [1,elem];         }         elem = elem.previousSibling;     }@@ -223,7 +153,7 @@     var len = elem.childNodes.length;     for(var i = len-1; i >= 0; --i) {         if(typeof elem.childNodes[i].tagName != 'undefined') {-            return [1,[0,elem.childNodes[i]]];+            return [1,elem.childNodes[i]];         }     }     return [0];@@ -234,7 +164,7 @@     var len = elem.childNodes.length;     for(var i = 0; i < len; i++) {         if(typeof elem.childNodes[i].tagName != 'undefined') {-            return [1,[0,elem.childNodes[i]]];+            return [1,elem.childNodes[i]];         }     }     return [0];@@ -246,7 +176,7 @@     var len = elem.childNodes.length;     for(var i = len-1; i >= 0; --i) {         if(typeof elem.childNodes[i].tagName != 'undefined') {-            children = [1, [0,elem.childNodes[i]], children];+            children = [1, elem.childNodes[i], children];         }     }     return children;@@ -256,7 +186,7 @@     children = E(children);     jsClearChildren(elem, 0);     while(children[0] === 1) {-        elem.appendChild(E(E(children[1])[1]));+        elem.appendChild(E(children[1]));         children = E(children[2]);     } }@@ -277,14 +207,12 @@     strs = E(strs);     while(strs[0]) {         strs = E(strs);-        arr.push(E(strs[1])[1]);+        arr.push(E(strs[1]));         strs = E(strs[2]);     }     return arr.join(sep); } -var jsJSONParse = JSON.parse;- // JSON stringify a string function jsStringify(str) {     return JSON.stringify(str);@@ -332,7 +260,7 @@             }             var xs = [0];             for(var i = 0; i < ks.length; i++) {-                xs = [1, [0, [0,ks[i]], toHS(obj[ks[i]])], xs];+                xs = [1, [0, ks[i], toHS(obj[ks[i]])], xs];             }             return [4, xs];         }@@ -346,23 +274,6 @@     return [1, toHS(arr[elem]), new T(function() {return arr2lst_json(arr,elem+1);}),true] } -function arr2lst(arr, elem) {-    if(elem >= arr.length) {-        return [0];-    }-    return [1, arr[elem], new T(function() {return arr2lst(arr,elem+1);})]-}-window['arr2lst'] = arr2lst;--function lst2arr(xs) {-    var arr = [];-    for(; xs[0]; xs = E(xs[2])) {-        arr.push(E(xs[1]));-    }-    return arr;-}-window['lst2arr'] = lst2arr;- function ajaxReq(method, url, async, postdata, cb) {     var xhr = new XMLHttpRequest();     xhr.open(method, url, async);@@ -374,7 +285,7 @@     xhr.onreadystatechange = function() {         if(xhr.readyState == 4) {             if(xhr.status == 200) {-                B(A(cb,[[1,[0,xhr.responseText]],0]));+                B(A(cb,[[1,xhr.responseText],0]));             } else {                 B(A(cb,[[0],0])); // Nothing             }@@ -383,32 +294,10 @@     xhr.send(postdata); } -// Create a little endian ArrayBuffer representation of something.-function toABHost(v, n, x) {-    var a = new ArrayBuffer(n);-    new window[v](a)[0] = x;-    return a;-}--function toABSwap(v, n, x) {-    var a = new ArrayBuffer(n);-    new window[v](a)[0] = x;-    var bs = new Uint8Array(a);-    for(var i = 0, j = n-1; i < j; ++i, --j) {-        var tmp = bs[i];-        bs[i] = bs[j];-        bs[j] = tmp;-    }-    return a;-}--window['toABle'] = toABHost;-window['toABbe'] = toABSwap;--// Swap byte order if host is not little endian.-var buffer = new ArrayBuffer(2);-new DataView(buffer).setInt16(0, 256, true);-if(new Int16Array(buffer)[0] !== 256) {-    window['toABle'] = toABSwap;-    window['toABbe'] = toABHost;+/* gettimeofday(2) */+function gettimeofday(tv, _tz) {+    var t = new Date().getTime();+    writeOffAddr("i32", 4, tv, 0, (t/1000)|0);+    writeOffAddr("i32", 4, tv, 1, ((t%1000)*1000)|0);+    return 0; }

@@ -1,21 +1,21 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, CPP #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, CPP,+             OverloadedStrings #-} -- | 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,+    JSString, JSAny, URL,     alert, prompt, eval, writeLog, catJSStr, fromJSStr,-    module Haste.JSType, module Haste.DOM, module Haste.Callback,+    module Haste.JSType, module Haste.DOM.Core, module Haste.Timer,     module Haste.Random, module Haste.Hash   ) where import Haste.Prim-import Haste.Callback hiding (jsSetCB, jsSetTimeout, GenericCallback)-import qualified Haste.Callback as CB (GenericCallback)+import Haste.Timer import Haste.Random import Haste.JSType-import Haste.DOM+import Haste.DOM.Core import Haste.Hash import Control.Monad.IO.Class @@ -24,6 +24,7 @@ foreign import ccall jsLog    :: JSString -> IO () foreign import ccall jsPrompt :: JSString -> IO JSString foreign import ccall jsEval   :: JSString -> IO JSString+ #else jsAlert  :: JSString -> IO () jsAlert = error "Tried to use jsAlert on server side!"

@@ -2,11 +2,9 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings        #-} -- | Low level XMLHttpRequest support. IE6 and older are not supported.-module Haste.Ajax (Method (..), URL, Key, Val, textRequest, textRequest_,-                   jsonRequest, jsonRequest_) where+module Haste.Ajax (Method (..), URL, ajaxRequest, noParams) where import Haste.Prim-import Haste.Callback-import Haste.JSON+import Haste.JSType import Control.Monad.IO.Class  #ifdef __HASTE__@@ -14,81 +12,48 @@                              -> JSString    -- url                              -> Bool        -- async?                              -> JSString    -- POST data-                             -> JSFun (Maybe JSString -> IO ())+                             -> Ptr (Maybe JSString -> IO ())                              -> IO () #else-ajaxReq :: JSString -> JSString -> Bool -> JSString -> JSFun (Maybe JSString -> IO ()) -> IO ()+ajaxReq :: JSString -> JSString -> Bool -> JSString -> Ptr (Maybe JSString -> IO ()) -> IO () ajaxReq = error "Tried to use ajaxReq in native code!" #endif  data Method = GET | POST deriving Show-type Key = String-type Val = String --- | Make an AJAX request to a URL, treating the response as plain text.-textRequest :: MonadIO m-            => Method-            -> URL-            -> [(Key, Val)]-            -> (Maybe String -> IO ())-            -> m ()-textRequest m url kv cb = do-  _ <- liftIO $ ajaxReq (toJSStr $ show m) url' True "" cb'-  return ()-  where-    cb' = mkCallback $ cb . fmap fromJSStr-    kv' = map (\(k,v) -> (toJSStr k, toJSStr v)) kv-    url' = if null kv-             then toJSStr url-             else catJSStr "?" [toJSStr url, toQueryString kv']---- | Same as 'textRequest' but deals with JSStrings instead of Strings.-textRequest_ :: MonadIO m-             => Method-             -> JSString-             -> [(JSString, JSString)]-             -> (Maybe JSString -> IO ())-             -> m ()-textRequest_ m url kv cb = liftIO $ do-  _ <- ajaxReq (toJSStr $ show m) url' True "" (mkCallback cb)-  return ()-  where-    url' = if null kv then url else catJSStr "?" [url, toQueryString kv]+-- | Pass to 'ajaxRequest' instead of @[]@ when no parameters are needed, to+--   avoid type ambiguity errors.+noParams :: [((), ())]+noParams = [] --- | Make an AJAX request to a URL, interpreting the response as JSON.-jsonRequest :: MonadIO m-            => Method-            -> URL-            -> [(Key, Val)]-            -> (Maybe JSON -> IO ())+-- | Perform an AJAX request.+ajaxRequest :: (MonadIO m, JSType a, JSType b, JSType c)+            => Method   -- ^ GET or POST. For GET, pass all params in URL.+                        --   For POST, pass all params as post data.+            -> URL      -- ^ URL to make AJAX request to.+            -> [(a, b)] -- ^ A list of (key, value) parameters.+            -> (Maybe c -> IO ()) -- ^ Callback to invoke on completion.             -> m ()-jsonRequest m url kv cb = liftIO $ do-  jsonRequest_ m (toJSStr url)-                 (map (\(k,v) -> (toJSStr k, toJSStr v)) kv)-                 cb---- | Does the same thing as 'jsonRequest' but uses 'JSString's instead of---   Strings.-jsonRequest_ :: MonadIO m-             => Method-             -> JSString-             -> [(JSString, JSString)]-             -> (Maybe JSON -> IO ())-             -> m ()-jsonRequest_ m url kv cb = liftIO $ do-    _ <- ajaxReq (toJSStr $ show m) url' True pd cb'+ajaxRequest m url kv cb = liftIO $ do+    _ <- ajaxReq (showm m) url' True pd cb'     return ()   where-    liftEither (Right x) = Just x-    liftEither _         = Nothing-    cb' = mkCallback $ \mjson -> cb (mjson >>= liftEither . decodeJSON)+    showm GET  = "GET"+    showm POST = "POST"+    cb' = toPtr $ cb . fromJSS+    fromJSS (Just jss) = fromJSString jss+    fromJSS _          = Nothing     url' = case m of-             GET -> if null kv then url else catJSStr "?" [url, toQueryString kv]-             POST -> url+           GET+             | null kv   -> toJSString url+             | otherwise -> catJSStr "?" [toJSString url, toQueryString kv]+           POST -> toJSString url     pd = case m of            GET -> ""-           POST -> if null kv then "" else toQueryString kv-+           POST+             | null kv   -> ""+             | otherwise -> toQueryString kv -toQueryString :: [(JSString, JSString)] -> JSString-toQueryString = catJSStr "&" . map (\(k,v) -> catJSStr "=" [k,v])+toQueryString :: (JSType a, JSType b) =>[(a, b)] -> JSString+toQueryString = catJSStr "&" . map f+  where f (k, v) = catJSStr "=" [toJSString k,toJSString v]

@@ -0,0 +1,350 @@+-- For the FFI+{-# LANGUAGE ForeignFunctionInterface, PatternGuards, CPP, BangPatterns #-}++-- For generic default instances+{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances,+             FlexibleContexts, OverloadedStrings, DefaultSignatures,+             OverlappingInstances #-}++-- For less annoying instances+{-# LANGUAGE TupleSections #-}++-- | Converting to/from JS-native data.+module Haste.Any (+    ToAny (..), FromAny (..), Generic, JSAny (..),+    Opaque, toOpaque, fromOpaque,+    nullValue, toObject, has, get, index+  ) where+import GHC.Generics+import Haste.Prim+import Haste.JSType+import Data.Int+import Data.Word+import Unsafe.Coerce+import Control.Applicative++#ifdef __HASTE__+foreign import ccall __lst2arr :: Ptr [a] -> JSAny+foreign import ccall __arr2lst :: Int -> JSAny -> Ptr [a]+foreign import ccall "String" jsString :: JSAny -> JSString+foreign import ccall "Number" jsNumber :: JSAny -> Double+foreign import ccall "__jsNull" jsNull :: JSAny+foreign import ccall "__jsTrue" jsTrue :: JSAny+foreign import ccall "__jsFalse" jsFalse :: JSAny+foreign import ccall __new :: IO JSAny+foreign import ccall __set :: JSAny -> JSString -> JSAny -> IO ()+foreign import ccall __get :: JSAny -> JSString -> IO JSAny+foreign import ccall __has :: JSAny -> JSString -> IO Bool+#else+__new :: IO JSAny+__new = return undefined+__get :: JSAny -> JSString -> IO JSAny+__get _ _ = return undefined+__set :: JSAny -> JSString -> JSAny -> IO ()+__set _ _ _ = return ()+__has :: JSAny -> JSString -> IO Bool+__has _ _ = return False+__lst2arr :: Ptr [a] -> JSAny+__lst2arr _ = undefined+__arr2lst :: Int -> JSAny -> Ptr [a]+__arr2lst _ _ = undefined+jsString :: JSAny -> JSString+jsString _ = undefined+jsNumber :: JSAny -> Double+jsNumber _ = undefined+jsNull, jsTrue, jsFalse :: JSAny+jsNull = undefined+jsTrue = undefined+jsFalse = undefined+#endif+{-+  For theoretical purposes, imagine the following here:+  foreign import ccall __intToAny :: Int -> JSAny+  ...+  In practice, however, we use unsafeCoerce for that to avoid the roundtrip.+-}++-- | The JS value null.+nullValue :: JSAny+nullValue = jsNull++-- | Build a new JS object from a list of key:value pairs.+toObject :: [(JSString, JSAny)] -> JSAny+toObject ps = veryUnsafePerformIO $ do+  o <- __new+  mapM_ (uncurry $ __set o) ps+  return o++-- | Read a member from a JS object. Throws an error if the member can not be+--   marshalled into a value of type @a@.+{-# INLINE get #-}+get :: FromAny a => JSAny -> JSString -> IO a+get o k = __get o k >>= fromAny++{-# INLINE index #-}+-- | Read an element from a JS array. Throws an error if the member can not be+--   marshalled into a value of type @a@.+index :: FromAny a => JSAny -> Int -> IO a+index o k = __get o (unsafeCoerce k) >>= fromAny++-- | Check if a JS object has a particular member.+{-# INLINE has #-}+has :: JSAny -> JSString -> IO Bool+has = __has++-- | Any type that can be converted into a JavaScript value.+class ToAny a where+  -- | Build a JS object from a Haskell value.+  --   The default instance creates an object from any type that derives+  --   'Generic' according to the following rules:+  --   * Records turn into plain JS objects, with record names as field names.+  --   * Non-record product types turn into objects containing a @$data@ field+  --     which contains all of the constructor's unnamed fields.+  --   * Values of enum types turn into strings matching their constructors.+  --   * Non-enum types with more than one constructor gain an extra field,+  --     @$tag@, which contains the name of the constructor used to create the+  --     object.+  toAny :: a -> JSAny+  default toAny :: (GToAny (Rep a), Generic a) => a -> JSAny+  toAny x =+    case gToAny False g of+      Tree x' -> toObject x'+      One  x' -> if isEnum g then x' else toAny [x']+      List x' -> toAny x'+    where g = from x++  listToAny :: [a] -> JSAny+  listToAny = __lst2arr . toPtr . map toAny++-- | Any type that can be converted from a JavaScript value.+class FromAny a where+  -- | Convert a value from JS with a reasonable conversion if an exact match+  --   is not possible. Examples of reasonable conversions would be truncating+  --   floating point numbers to integers, or turning signed integers into+  --   unsigned.+  fromAny :: JSAny -> IO a++  listFromAny :: JSAny -> IO [a]+  listFromAny = mapM fromAny . fromPtr . __arr2lst 0++-- | The Opaque type is inhabited by values that can be passed to JavaScript+--   using their raw Haskell representation. Opaque values are completely+--   useless to JS code, and should not be inspected. This is useful for,+--   for instance, storing data in some JS-native data structure for later+--   retrieval.+newtype Opaque a = Opaque {fromOpaque :: a}++toOpaque :: a -> Opaque a+toOpaque = Opaque++++-- ToAny instances+instance ToAny JSAny where toAny = unsafeCoerce+instance ToAny (Ptr a) where toAny = unsafeCoerce+instance ToAny JSString where toAny = unsafeCoerce+instance ToAny Int where toAny = unsafeCoerce+instance ToAny Int8 where toAny = unsafeCoerce+instance ToAny Int16 where toAny = unsafeCoerce+instance ToAny Int32 where toAny = unsafeCoerce+instance ToAny Word where toAny = unsafeCoerce+instance ToAny Word8 where toAny = unsafeCoerce+instance ToAny Word16 where toAny = unsafeCoerce+instance ToAny Word32 where toAny = unsafeCoerce+instance ToAny Float where toAny = unsafeCoerce+instance ToAny Double where toAny = unsafeCoerce+instance ToAny Char where+  toAny = unsafeCoerce+  listToAny = toAny . toJSStr+instance ToAny () where+  toAny _ = jsNull+instance ToAny (Opaque a) where+  toAny (Opaque x) = unsafeCoerce $ toPtr x+instance ToAny Bool where+  toAny True  = jsTrue+  toAny False = jsFalse++-- | Lists are marshalled into arrays, with the exception of 'String'.+instance ToAny a => ToAny [a] where+  toAny = listToAny++-- | Maybe is simply a nullable type. Nothing is equivalent to null, and any+--   non-null value is equivalent to x in Just x.+instance ToAny a => ToAny (Maybe a) where+  toAny Nothing  = jsNull+  toAny (Just x) = toAny x++-- | Tuples are marshalled into arrays.+instance (ToAny a, ToAny b) => ToAny (a, b) where+  toAny (a, b) = toAny [toAny a, toAny b]++instance (ToAny a, ToAny b, ToAny c) => ToAny (a, b, c) where+  toAny (a, b, c) = toAny [toAny a, toAny b, toAny c]++instance (ToAny a, ToAny b, ToAny c, ToAny d) =>+          ToAny (a, b, c, d) where+  toAny (a, b, c, d) = toAny [toAny a, toAny b, toAny c, toAny d]++instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e) =>+          ToAny (a, b, c, d, e) where+  toAny (a, b, c, d, e) = toAny [toAny a,toAny b,toAny c,toAny d,toAny e]++instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e,+          ToAny f) => ToAny (a, b, c, d, e, f) where+  toAny (a, b, c, d, e, f) =+    toAny [toAny a, toAny b, toAny c, toAny d, toAny e, toAny f]++instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e,+          ToAny f, ToAny g) => ToAny (a, b, c, d, e, f, g) where+  toAny (a, b, c, d, e, f, g) =+    toAny [toAny a,toAny b,toAny c,toAny d,toAny e,toAny f,toAny g]++++instance FromAny JSAny where+  fromAny x = return (unsafeCoerce x)+instance FromAny (Ptr a) where+  fromAny x = return (unsafeCoerce x)+instance FromAny JSString where+  fromAny x = return (jsString x)+instance FromAny Int where+  fromAny x = return (convert (jsNumber x))+instance FromAny Int8 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Int16 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Int32 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Word where+  fromAny x = return (convert (jsNumber x))+instance FromAny Word8 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Word16 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Word32 where+  fromAny x = return (convert (jsNumber x))+instance FromAny Float where+  fromAny x = return (unsafeCoerce (jsNumber x))+instance FromAny Double where+  fromAny x = return (unsafeCoerce x) -- return (jsNumber x)+instance FromAny Char where+  fromAny x = return (unsafeCoerce (jsNumber x))+  listFromAny x = fromJSStr <$> fromAny x+instance FromAny () where+  fromAny _ = return ()+instance FromAny (Opaque a) where+  fromAny x = Opaque . fromPtr <$> fromAny x+instance FromAny Bool where+  fromAny x | x == jsTrue = return True+            | otherwise   = return False++instance FromAny a => FromAny [a] where+  fromAny = listFromAny++instance FromAny a => FromAny (Maybe a) where+  fromAny x | x == jsNull = return Nothing+            | otherwise   = Just <$> fromAny x++instance (FromAny a, FromAny b) => FromAny (a, b) where+  fromAny x = do+    [a,b] <- fromAny x+    (,) <$> fromAny a <*> fromAny b++instance (FromAny a, FromAny b, FromAny c) => FromAny (a, b, c) where+  fromAny x = do+    [a,b,c] <- fromAny x+    (,,) <$> fromAny a <*> fromAny b <*> fromAny c++instance (FromAny a, FromAny b, FromAny c, FromAny d) =>+          FromAny (a, b, c, d) where+  fromAny x = do+    [a,b,c,d] <- fromAny x+    (,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d++instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e) =>+          FromAny (a, b, c, d, e) where+  fromAny x = do+    [a,b,c,d,e] <- fromAny x+    (,,,,) <$> fromAny a <*> fromAny b <*> fromAny c+           <*> fromAny d <*> fromAny e++instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e, FromAny f) =>+          FromAny (a, b, c, d, e, f) where+  fromAny x = do+    [a,b,c,d,e,f] <- fromAny x+    (,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c+            <*> fromAny d <*> fromAny e <*> fromAny f++instance (FromAny a, FromAny b, FromAny c, FromAny d,+          FromAny e, FromAny f, FromAny g) =>+          FromAny (a, b, c, d, e, f, g) where+  fromAny x = do+    [a,b,c,d,e,f,g] <- fromAny x+    (,,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d+             <*> fromAny e <*> fromAny f <*> fromAny g++data Value = One !JSAny | List ![JSAny] | Tree ![(JSString, JSAny)]++-- Generic instances+class GToAny f where+  gToAny :: Bool -> f a -> Value+  isEnum :: f a -> Bool++instance GToAny U1 where+  gToAny _ U1 = error "U1: unpossible!"+  isEnum _    = True++instance ToAny a => GToAny (K1 i a) where+  gToAny _ (K1 x) = One (toAny x)+  isEnum _ = False++instance (Selector c, GToAny a) => GToAny (M1 S c a) where+  gToAny mcs (M1 x) = do+    case name of+      "" -> One  value+      _  -> Tree [(name, value)]+    where name  = toJSStr (selName (undefined :: M1 S c a ()))+          value =+            case gToAny mcs x of+              Tree x' -> toObject x'+              One  x' -> toAny x'+              List x' -> toAny x'+  isEnum _ = isEnum (undefined :: a ())++instance Constructor c => GToAny (M1 C c U1) where+  gToAny _ _ = One (toAny $ conName (undefined :: M1 C c U1 ()))+  isEnum _ = True++instance (Constructor c, GToAny a) => GToAny (M1 C c a) where+  gToAny many_constrs (M1 x)+    | many_constrs =+      case args of+        Tree args' -> Tree (("$tag", toAny tag) : args')+        One  arg   -> Tree [("$tag", toAny tag), ("$data", arg)]+        List args' -> Tree [("$tag", toAny tag), ("$data", toAny args')]+    | otherwise =+      args+    where+      tag  = conName (undefined :: M1 C c a ())+      args = gToAny many_constrs x+  isEnum _ = isEnum (undefined :: a ())++instance GToAny a => GToAny (M1 D c a) where+  gToAny cs (M1 x) = gToAny cs x+  isEnum _ = isEnum (undefined :: a ())++instance (GToAny a, GToAny b) => GToAny (a :*: b) where+  gToAny cs (a :*: b) =+    case (gToAny cs a, gToAny cs b) of+      (One l,   One r)   -> List [l, r]+      (One x,   List xs) -> List (x:xs)+      (List xs, One x)   -> List (xs ++ [x])+      (List l,  List r)  -> List (l ++ r)+      (Tree l,  Tree r)  -> Tree (l ++ r)+      (_,       _)       -> error "Tree :*: non-tree!"+  isEnum _ = False++instance (GToAny a, GToAny b) => GToAny (a :+: b) where+  gToAny _ (L1 x) = gToAny True x+  gToAny _ (R1 x) = gToAny True x+  isEnum _ = isEnum (undefined :: a ()) && isEnum (undefined :: b ())

@@ -9,26 +9,22 @@     Sessions, SessionID,     liftServerIO, forkServerIO, remote, runApp,     (<.>), getSessionID, getActiveSessions, onSessionEnd,-    AppCfg, cfgURL, cfgPort, mkConfig,+    AppCfg, cfgHost, cfgPort, mkConfig,     Client,     runClient, onServer, liftIO,     JSString, JSAny, URL, alert, prompt, eval, writeLog, catJSStr, fromJSStr,-    module Haste.App.Events,-    module Haste.DOM,+    module Haste.DOM.Core,     module Haste.Random,     module Haste.JSType,     module Haste.Hash,-    module Haste.Binary,-    module Data.Default+    module Haste.Binary   ) where import Haste.App.Client import Haste.App.Monad-import Haste.App.Events import Haste.Binary (Binary (..))-import Haste.DOM+import Haste.DOM.Core import Haste.Random import Haste.JSType import Haste.Hash import Haste import Control.Monad.IO.Class-import Data.Default

@@ -6,10 +6,13 @@   ) where import Haste import Haste.WebSockets+import Haste.Events.Core import Haste.Binary hiding (get) import Haste.App.Monad import Haste.App.Protocol+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Monad (ap, join) import Control.Monad.IO.Class import Control.Exception (throw)@@ -55,17 +58,14 @@     x <- liftIO m     return x -instance GenericCallback (Client ()) Client where-  type CB (Client ()) = IO ()-  mkcb toIO m = toIO m-  mkIOfier _ = do-    st <- get id-    return $ concurrent . runClientCIO st- instance MonadBlob Client where   getBlobData = liftCIO . getBlobData   getBlobText' = liftCIO . getBlobText' +instance MonadEvent Client where+  mkHandler f = do+    st <- get id+    return $ concurrent . runClientCIO st . f  -- | Lift a CIO action into the Client monad. liftCIO :: CIO a -> Client a@@ -122,7 +122,8 @@ --   the program terminates. runClient :: Client () -> App Done runClient m = do-  url <- cfgURL `fmap` getAppConfig+  cfg <- getAppConfig+  let url = "ws://" ++ cfgHost cfg ++ ":" ++ show (cfgPort cfg)   return . Done $ runClient_ url m  -- | Run a client computation from the CIO monad, using a pre-specified state.

@@ -1,4 +1,5 @@ {-# LANGUAGE EmptyDataDecls #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Wraps Haste.Concurrent to work with Haste.App. --   Task switching happens whenever a thread is blocked in an MVar, so things --   like polling an IORef in a loop will starve all other threads.

@@ -1,40 +0,0 @@-{-# LANGUAGE TypeFamilies, GADTs, FlexibleInstances, ForeignFunctionInterface,-             CPP #-}--- | Event handlers for Haste.App. If you're using Haste.App, you should use---   the functions provided by this module rather than the ones from---   Haste.Callback.-module Haste.App.Events (-    ClientCallback, CB.Event (..),-    onEvent, setTimeout, CB.evtName-  ) where-import qualified Haste.Callback as CB-import Haste.App.Client-import Haste.Concurrent-import Haste.DOM---- | Bake a value of type a -> ... -> Client b into a -> ... -> IO b-class ClientCallback a where-  type T a-  cbify :: ClientState -> a -> T a--instance ClientCallback (Client ()) where-  type T (Client ()) = IO ()-  cbify cs = concurrent . runClientCIO cs--instance ClientCallback b => ClientCallback (a -> b) where-  type T (a -> b) = a -> T b-  cbify cs f = \x -> cbify cs (f x)---- | Set a handler for a given event.-onEvent :: ClientCallback a => Elem -> CB.Event Client a -> a -> Client ()-onEvent e evt f = do-    cs <- get id-    _ <- liftIO . CB.jsSetCB e (CB.evtName evt) . CB.mkCallback $! cbify cs f-    return ()---- | Wrapper for window.setTimeout; execute the given computation after a delay---   given in milliseconds.-setTimeout :: Int -> Client () -> Client ()-setTimeout delay cb = do-  cs <- get id-  liftIO $ CB.jsSetTimeout delay (CB.mkCallback $! cbify cs cb)

@@ -1,52 +1,51 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PatternGuards #-} -- | Haste.App startup monad and configuration. module Haste.App.Monad (     Remotable,     App, Server, Sessions, SessionID, Remote (..), Done (..),-    AppCfg, def, mkConfig, cfgURL, cfgPort,+    AppCfg, defaultConfig, mkConfig, cfgHost, cfgPort,     liftServerIO, forkServerIO, remote, getAppConfig,     runApp, (<.>), getSessionID, getActiveSessions, onSessionEnd   ) where+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Monad (ap) import Control.Monad.IO.Class import Haste.Binary-import Haste.Binary.Types import qualified Data.Map as M import qualified Data.Set as S import Haste.App.Protocol import Data.Word import Control.Concurrent (ThreadId) import Data.IORef-import Data.Default import System.IO.Unsafe #ifndef __HASTE__ import Haste.Binary.Types import Control.Concurrent (forkIO)-import Haste.Prim (toJSStr, fromJSStr) import Network.WebSockets as WS import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.UTF8 as BU import Control.Exception-import System.Random+import System.Random hiding (next) import Data.List (foldl') import Data.String #endif  data AppCfg = AppCfg {-    cfgURL                :: String,+    cfgHost               :: String,     cfgPort               :: Int,     cfgSessionEndHandlers :: [SessionID -> Server ()]   } -instance Default AppCfg where-  def = mkConfig "ws://localhost:24601" 24601+defaultConfig :: AppCfg+defaultConfig = mkConfig "localhost" 24601 --- | Create a default configuration from an URL and a port number.+-- | Create a default configuration from a host name and a port number. mkConfig :: String -> Int -> AppCfg-mkConfig url port = AppCfg {-    cfgURL = url,+mkConfig host port = AppCfg {+    cfgHost = host,     cfgPort = port,     cfgSessionEndHandlers = []   }@@ -104,8 +103,6 @@ --   used server-side. liftServerIO :: IO a -> App (Server a) #ifdef __HASTE__-{-# RULES "throw away liftServerIO"-          forall x. liftServerIO x = return Server #-} liftServerIO _ = return Server #else liftServerIO m = App $ \cfg _ cid exports -> do@@ -122,8 +119,6 @@ --   expected. forkServerIO :: Server () -> App (Server ThreadId) #ifdef __HASTE__-{-# RULES "throw away forkServerIO"-          forall x. forkServerIO x = return Server #-} forkServerIO _ = return Server #else forkServerIO (Server m) = App $ \cfg sessions cid exports -> do@@ -149,7 +144,7 @@ #else   serializify f (x:xs) = serializify (f $! fromEither $ decode (toBD x)) xs     where-      toBD (Blob x) = BlobData x+      toBD (Blob x') = BlobData x'       fromEither (Right val) = val       fromEither (Left e)    = error $ "Unable to deserialize data: " ++ e   serializify _ _      = error "The impossible happened in serializify!"@@ -158,9 +153,6 @@ -- | Make a function available to the client as an API call. remote :: Remotable a => a -> App (Remote a) #ifdef __HASTE__-{-# RULES "throw away remote's argument"-          forall x. remote x =-            App $ \c _ cid _ -> return (Remote cid [], cid+1, undefined, c) #-} remote _ = App $ \c _ cid _ ->     return (Remote cid [], cid+1, undefined, c) #else@@ -173,8 +165,6 @@ --   the order they were registered. onSessionEnd :: (SessionID -> Server ()) -> App () #ifdef __HASTE__-{-# RULES "throw away onSessionEnd argument"-          forall x. onSessionEnd x = return () #-} onSessionEnd _ = return () #else onSessionEnd s = App $ \cfg _ cid exports -> return $@@ -233,7 +223,7 @@       where         go = do           msg <- receiveData c-          forkIO $ do+          _ <- forkIO $ do             case decode (BlobData msg) of               Right (ServerCall nonce method args)                 | Just m <- M.lookup method exports -> do

@@ -1,7 +1,9 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, CPP #-} -- | Haste.App client-server protocol. module Haste.App.Protocol where+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Exception import Data.Typeable import Haste.Binary

@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedStrings, CPP #-}+-- | High-ish level bindings to the HTML5 audio tag and JS API.+module Haste.Audio (+    module Events,+    Audio, AudioSettings (..), AudioType (..), AudioSource (..),+    AudioPreload (..), AudioState (..), Seek (..),+    defaultAudioSettings,+    mkSource, newAudio, setSource,+    getState,+    setMute, isMute, toggleMute,+    setLooping, isLooping, toggleLooping,+    getVolume, setVolume, modVolume,+    play, pause, stop, togglePlaying,+    seek, getDuration, getCurrentTime+  ) where+import Haste.Audio.Events as Events+import Haste.DOM.JSString+import Haste.Foreign+import Haste.JSType+import Haste.Prim+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad+import Control.Monad.IO.Class+import Data.String++-- | Represents an audio player.+data Audio = Audio Elem++instance IsElem Audio where+  elemOf (Audio e) = e+  fromElem e = do+    tn <- getProp e "tagName"+    return $ case tn of+      "AUDIO" -> Just $ Audio e+      _       -> Nothing++data AudioState = Playing | Paused | Ended+  deriving (Show, Eq)+data AudioType = MP3 | OGG | WAV+  deriving (Show, Eq)+data AudioSource = AudioSource !AudioType !JSString+  deriving (Show, Eq)+data AudioPreload = None | Metadata | Auto+  deriving Eq+data Seek = Start | End | Seconds Double+  deriving Eq++instance JSType AudioPreload where+  toJSString None     = "none"+  toJSString Metadata = "metadata"+  toJSString Auto     = "auto"+  fromJSString "none"     = Just None+  fromJSString "metadata" = Just Metadata+  fromJSString "auto"     = Just Auto+  fromJSString _          = Nothing++data AudioSettings = AudioSettings {+    -- | Show controls?+    --   Default: False+    audioControls :: !Bool,+    -- | Immediately start playing?+    --   Default: False+    audioAutoplay :: !Bool,+    -- | Initially looping?+    --   Default: False+    audioLooping  :: !Bool,+    -- | How much audio to preload.+    --   Default: Auto+    audioPreload  :: !AudioPreload,+    -- | Initially muted?+    --   Default: False+    audioMuted    :: !Bool,+    -- | Initial volume+    --   Default: 0+    audioVolume   :: !Double+  }++defaultAudioSettings :: AudioSettings+defaultAudioSettings = AudioSettings {+    audioControls = False,+    audioAutoplay = False,+    audioLooping = False,+    audioPreload = Auto,+    audioMuted = False,+    audioVolume = 0+  }++-- | Create an audio source with automatically detected media type, based on+--   the given URL's file extension.+--   Returns Nothing if the given URL has an unrecognized media type.+mkSource :: JSString -> Maybe AudioSource+mkSource url =+  case take 3 $ reverse $ fromJSStr url of+    "3pm" -> Just $ AudioSource MP3 url+    "ggo" -> Just $ AudioSource OGG url+    "vaw" -> Just $ AudioSource WAV url+    _     -> Nothing++instance IsString AudioSource where+  fromString s =+    case mkSource $ Data.String.fromString s of+      Just src -> src+      _        -> error $ "Not a valid audio source: " ++ s++mimeStr :: AudioType -> JSString+mimeStr MP3 = "audio/mpeg"+mimeStr OGG = "audio/ogg"+mimeStr WAV = "audio/wav"++-- | Create a new audio element.+newAudio :: MonadIO m => AudioSettings -> [AudioSource] -> m Audio+newAudio cfg sources = liftIO $ do+  srcs <- forM sources $ \(AudioSource t url) -> do+    newElem "source" `with` ["type" =: mimeStr t, "src" =: toJSString url]+  Audio <$> newElem "audio" `with` [+      "controls" =: falseAsEmpty (audioControls cfg),+      "autoplay" =: falseAsEmpty (audioAutoplay cfg),+      "loop"     =: falseAsEmpty (audioLooping cfg),+      "muted"    =: falseAsEmpty (audioMuted cfg),+      "volume"   =: toJSString (audioVolume cfg),+      "preload"  =: toJSString (audioPreload cfg),+      children srcs+    ]++-- | Returns "true" or "", depending on the given boolean.+falseAsEmpty :: Bool -> JSString+falseAsEmpty True = "true"+falseAsEmpty _    = ""++-- | (Un)mute the given audio object.+setMute :: MonadIO m => Audio -> Bool -> m ()+setMute (Audio e) = setAttr e "muted" . falseAsEmpty++-- | Is the given audio object muted?+isMute :: MonadIO m => Audio -> m Bool+isMute (Audio e) = liftIO $ maybe False id . fromJSString <$> getProp e "muted"++-- | Mute/unmute.+toggleMute :: MonadIO m => Audio -> m ()+toggleMute a = isMute a >>= setMute a . not++-- | Set whether the given sound should loop upon completion or not.+setLooping :: MonadIO m => Audio -> Bool -> m ()+setLooping (Audio e) = setAttr e "loop" . falseAsEmpty++-- | Is the given audio object looping?+isLooping :: MonadIO m => Audio -> m Bool+isLooping (Audio e) =+  liftIO $ maybe False id . fromJSString <$> getProp e "looping"++-- | Toggle looping on/off.+toggleLooping :: MonadIO m => Audio -> m ()+toggleLooping a = isLooping a >>= setLooping a . not++-- | Starts playing audio from the given element.+play :: MonadIO m => Audio -> m ()+play a@(Audio e) = do+    st <- getState a+    when (st == Ended) $ seek a Start+    liftIO $ play' e+  where+    play' :: Elem -> IO ()+    play' = ffi "(function(x){x.play();})"++-- | Get the current state of the given audio object.+getState :: MonadIO m => Audio -> m AudioState+getState (Audio e) = liftIO $ do+  ended <- maybe False id . fromJSString <$> getProp e "ended"+  if ended+    then return Ended+    else maybe Playing paused . fromJSString <$> getProp e "paused"+  where+    paused True = Paused+    paused _    = Playing++-- | Pause the given audio element.+pause :: MonadIO m => Audio -> m ()+pause (Audio e) = liftIO $ pause' e++pause' :: Elem -> IO ()+pause' = ffi "(function(x){x.pause();})"++-- | If playing, stop. Otherwise, start playing.+togglePlaying :: MonadIO m => Audio -> m ()+togglePlaying a = do+  st <- getState a+  case st of+    Playing    -> pause a+    Ended      -> seek a Start >> play a+    Paused     -> play a++-- | Stop playing a track, and seek back to its beginning.+stop :: MonadIO m => Audio -> m ()+stop a = pause a >> seek a Start++-- | Get the volume for the given audio element as a value between 0 and 1.+getVolume :: MonadIO m => Audio -> m Double+getVolume (Audio e) = liftIO $ maybe 0 id . fromJSString <$> getProp e "volume"++-- | Set the volume for the given audio element. The value will be clamped to+--   [0, 1].+setVolume :: MonadIO m => Audio -> Double -> m ()+setVolume (Audio e) = setProp e "volume" . toJSString . clamp++-- | Modify the volume for the given audio element. The resulting volume will+--   be clamped to [0, 1].+modVolume :: MonadIO m => Audio -> Double -> m ()+modVolume a diff = getVolume a >>= setVolume a . (+ diff)++-- | Clamp a value to [0, 1].+clamp :: Double -> Double+clamp = max 0 . min 1++-- | Seek to the specified time.+seek :: MonadIO m => Audio -> Seek -> m ()+seek a@(Audio e) st = liftIO $ do+    case st of+      Start     -> seek' e 0+      End       -> getDuration a >>= seek' e+      Seconds s -> seek' e s+  where+    seek' :: Elem -> Double -> IO ()+    seek' = ffi "(function(e,t) {e.currentTime = t;})"++-- | Get the duration of the loaded sound, in seconds.+getDuration :: MonadIO m => Audio -> m Double+getDuration (Audio e) = do+  dur <- getProp e "duration"+  case fromJSString dur of+    Just d -> return d+    _      -> return 0++-- | Get the current play time of the loaded sound, in seconds.+getCurrentTime :: MonadIO m => Audio -> m Double+getCurrentTime (Audio e) = do+  dur <- getProp e "currentTime"+  case fromJSString dur of+    Just d -> return d+    _      -> return 0++-- | Set the source of the given audio element.+setSource :: MonadIO m => Audio -> AudioSource -> m ()+setSource (Audio e) (AudioSource _ url) = setProp e "src" (toJSString url)

@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies, OverloadedStrings #-}+-- | Audio related events.+module Haste.Audio.Events where+import Haste.Events.Core++data AudioEvent+  = AudioEnded       -- ^ Audio playback ended.+  | AudioError       -- ^ There was some kind of error.+  | AudioPaused      -- ^ Audio paused.+  | AudioResumed     -- ^ Resumed playing after pause.+  | AudioPlaying     -- ^ Audio started playing, initially or after pause.+  | AudioSeekBegins  -- ^ Seek operation starts.+  | AudioSeekEnds    -- ^ Seek operation completes.+  | AudioTimeUpdate  -- ^ Audio object't current time changed.+  | AudioProgress    -- ^ Progress was made downloading audio.+  | AudioStalled     -- ^ Audio download stalled.+  | AudioLoadStart   -- ^ Start downloading audio.+  | AudioLoadSuspend -- ^ Finished or paused downloading audio.++instance Event AudioEvent where+  type EventData AudioEvent = ()+  eventName AudioEnded       = "ended"+  eventName AudioError       = "error"+  eventName AudioPaused      = "pause"+  eventName AudioResumed     = "play"+  eventName AudioPlaying     = "playing"+  eventName AudioSeekBegins  = "seeking"+  eventName AudioSeekEnds    = "seeked"+  eventName AudioTimeUpdate  = "timeupdate"+  eventName AudioProgress    = "progress"+  eventName AudioStalled     = "stalled"+  eventName AudioLoadStart   = "loadstart"+  eventName AudioLoadSuspend = "suspend"+  eventData _ _ = return ()

@@ -1,6 +1,8 @@ {-# LANGUAGE MagicHash, CPP, MultiParamTypeClasses, OverloadedStrings,-             TypeSynonymInstances , FlexibleInstances, OverlappingInstances,-             GeneralizedNewtypeDeriving, BangPatterns, TypeOperators, KindSignatures, DefaultSignatures, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables #-}+             TypeSynonymInstances , FlexibleInstances,+             GeneralizedNewtypeDeriving, BangPatterns, TypeOperators,+             KindSignatures, DefaultSignatures, FlexibleInstances,+             TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables #-} -- | Handling of Javascript-native binary blobs. -- -- Generics borrowed from the binary package by Lennart Kolmodin (released under BSD3)@@ -10,20 +12,26 @@     MonadBlob (..), Binary (..), getBlobText,     Blob, BlobData,     blobSize, blobDataSize, toByteString, toBlob, strToBlob,-    encode, decode+    encode, decode, decodeBlob   )where import Data.Int import Data.Word import Data.Char+import qualified Haste.JSString as J (length) import Haste.Prim-import Haste.Concurrent hiding (encode, decode)-import Haste.Foreign+import Haste.Concurrent+import Haste.Foreign hiding (get) import Haste.Binary.Types import Haste.Binary.Put import Haste.Binary.Get+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import GHC.Generics import Data.Bits+#ifndef __HASTE__+import qualified Data.ByteString.Lazy.Char8 as BS (unpack)+#endif  class Monad m => MonadBlob m where   -- | Retrieve the raw data from a blob.@@ -36,30 +44,31 @@ getBlobText b = getBlobText' b >>= return . fromJSStr  instance MonadBlob CIO where+#ifdef __HASTE__   getBlobData b = do       res <- newEmptyMVar-      liftIO $ convertBlob b (toOpaque $ mkBlobData res (blobSize b))+      liftIO $ convertBlob b (mkBlobData res (blobSize b))       takeMVar res     where-#ifdef __HASTE__       mkBlobData res len x = concurrent $ do         putMVar res (BlobData 0 len x)-#else-      mkBlobData = undefined-#endif -      convertBlob :: Blob -> Opaque (Unpacked -> IO ()) -> IO ()+      convertBlob :: Blob -> (JSAny -> IO ()) -> IO ()       convertBlob = ffi-        "(function(b,cb){var r=new FileReader();r.onload=function(){B(A(cb,[new DataView(r.result),0]));};r.readAsArrayBuffer(b);})"+        "(function(b,cb){var r=new FileReader();r.onload=function(){cb(new DataView(r.result));};r.readAsArrayBuffer(b);})"    getBlobText' b = do       res <- newEmptyMVar-      liftIO $ convertBlob b (toOpaque $ concurrent . putMVar res)+      liftIO $ convertBlob b (concurrent . putMVar res)       takeMVar res     where-      convertBlob :: Blob -> Opaque (JSString -> IO ()) -> IO ()+      convertBlob :: Blob -> (JSString -> IO ()) -> IO ()       convertBlob = ffi-        "(function(b,cb){var r=new FileReader();r.onload=function(){B(A(cb,[[0,r.result],0]));};r.readAsText(b);})"+        "(function(b,cb){var r=new FileReader();r.onload=function(){cb(r.result);};r.readAsText(b);})"+#else+  getBlobData (Blob b) = return (BlobData b)+  getBlobText' (Blob b) = return . toJSStr $ BS.unpack b+#endif  -- | Somewhat efficient serialization/deserialization to/from binary Blobs. --   The layout of the binaries produced/read by get/put and encode/decode may@@ -152,9 +161,20 @@     putWord32le (fromIntegral $ length xs)     mapM_ put xs   get = do-    len <- getWord32le-    flip mapM [1..len] $ \_ -> get+      len <- getWord32le+      getList len []+    where+      getList 0 xs = return $ reverse xs+      getList n xs = get >>= \x -> getList (n-1) (x:xs) +instance Binary JSString where+  {-# NOINLINE put #-}+  put s = do+    putWord32le $ fromIntegral $ J.length s+    putJSString s+  {-# NOINLINE get #-}+  get = get >>= getJSString+     instance Binary Blob where   {-# NOINLINE put #-}   put b = do@@ -168,14 +188,23 @@  instance Binary Char where   put = put . ord-  get = chr <$> get+  get = get >>= \x ->+    case chr x of+      !x' -> return x' +-- | Encode any serializable data into a 'Blob'. encode :: Binary a => a -> Blob encode x = runPut (put x) +-- | Decode any deserializable data from a 'BlobData'. decode :: Binary a => BlobData -> Either String a decode = runGet get +-- | Decode a 'Blob' into some deserializable value, inconveniently locked up+--   inside the 'CIO' monad (or any other concurrent monad) due to the somewhat+--   special way JavaScript uses to deal with binary data.+decodeBlob :: (MonadBlob m, Binary a) => Blob -> m (Either String a)+decodeBlob b = getBlobData b >>= return . decode  -- Type without constructors instance GBinary V1 where

@@ -4,120 +4,129 @@     getWord8, getWord16le, getWord32le,     getInt8, getInt16le, getInt32le,     getFloat32le, getFloat64le,-    getBytes, skip,+    getBytes, getJSString, skip,     runGet   ) where import Data.Int import Data.Word import Haste.Prim-import Haste.Foreign import Haste.Binary.Types+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Monad import System.IO.Unsafe-#ifndef __HASTE__+#ifdef __HASTE__+import Haste.Foreign hiding (get)+#else+import qualified Control.Exception as Ex+import Data.Char (chr) import qualified Data.Binary as B import qualified Data.Binary.IEEE754 as BI import qualified Data.Binary.Get as BG-import qualified Control.Exception as Ex #endif  #ifdef __HASTE__-data Get a = Get {unG :: Unpacked -> Int -> Either String (Int, a)}+data Result a = Ok !Int !a | Fail !String+data Get a = Get {unG :: JSAny -> Int -> Result a}  instance Functor Get where-  fmap f (Get m) = Get $ \buf next -> fmap (fmap f) (m buf next)+  fmap f (Get m) = Get $ \buf next ->+    case m buf next of+      Ok next' x -> Ok next' (f x)+      Fail s     -> Fail s  instance Applicative Get where   (<*>) = ap   pure  = return  instance Monad Get where-  return x = Get $ \_ next -> Right (next, x)+  return x = Get $ \_ next -> Ok next x   (Get m) >>= f = Get $ \buf next ->     case m buf next of-      Right (next', x) -> unG (f x) buf next'-      Left e           -> Left e-  fail s = Get $ \_ _ -> Left s+      Ok next' x -> unG (f x) buf next'+      Fail e     -> Fail e+  fail s = Get $ \_ _ -> Fail s -{-# NOINLINE getW8 #-}-getW8 :: Unpacked -> Int -> IO Word8+getW8 :: JSAny -> Int -> IO Word8 getW8 = ffi "(function(b,i){return b.getUint8(i);})"  getWord8 :: Get Word8 getWord8 =-  Get $ \buf next -> Right (next+1, unsafePerformIO $ getW8 buf next)+  Get $ \buf next -> Ok (next+1) (unsafePerformIO $ getW8 buf next) -{-# NOINLINE getW16le #-}-getW16le :: Unpacked -> Int -> IO Word16+getW16le :: JSAny -> Int -> IO Word16 getW16le = ffi "(function(b,i){return b.getUint16(i,true);})"  getWord16le :: Get Word16 getWord16le =-  Get $ \buf next -> Right (next+2, unsafePerformIO $ getW16le buf next)+  Get $ \buf next -> Ok (next+2) (unsafePerformIO $ getW16le buf next) -{-# NOINLINE getW32le #-}-getW32le :: Unpacked -> Int -> IO Word32+getW32le :: JSAny -> Int -> IO Word32 getW32le = ffi "(function(b,i){return b.getUint32(i,true);})"  getWord32le :: Get Word32 getWord32le =-  Get $ \buf next -> Right (next+4, unsafePerformIO $ getW32le buf next)+  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getW32le buf next) -{-# NOINLINE getI8 #-}-getI8 :: Unpacked -> Int -> IO Int8+getI8 :: JSAny -> Int -> IO Int8 getI8 = ffi "(function(b,i){return b.getInt8(i);})"  getInt8 :: Get Int8 getInt8 =-  Get $ \buf next -> Right (next+1, unsafePerformIO $ getI8 buf next)+  Get $ \buf next -> Ok (next+1) (unsafePerformIO $ getI8 buf next) -{-# NOINLINE getI16le #-}-getI16le :: Unpacked -> Int -> IO Int16+getI16le :: JSAny -> Int -> IO Int16 getI16le = ffi "(function(b,i){return b.getInt16(i,true);})"  getInt16le :: Get Int16 getInt16le =-  Get $ \buf next -> Right (next+2, unsafePerformIO $ getI16le buf next)+  Get $ \buf next -> Ok (next+2) (unsafePerformIO $ getI16le buf next) -{-# NOINLINE getI32le #-}-getI32le :: Unpacked -> Int -> IO Int32+getI32le :: JSAny -> Int -> IO Int32 getI32le = ffi "(function(b,i){return b.getInt32(i,true);})"  getInt32le :: Get Int32 getInt32le =-  Get $ \buf next -> Right (next+4, unsafePerformIO $ getI32le buf next)+  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getI32le buf next) -{-# NOINLINE getF32le #-}-getF32le :: Unpacked -> Int -> IO Float+getF32le :: JSAny -> Int -> IO Float getF32le = ffi "(function(b,i){return b.getFloat32(i,true);})"  getFloat32le :: Get Float getFloat32le =-  Get $ \buf next -> Right (next+4, unsafePerformIO $ getF32le buf next)+  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getF32le buf next) -{-# NOINLINE getF64le #-}-getF64le :: Unpacked -> Int -> IO Double+getF64le :: JSAny -> Int -> IO Double getF64le = ffi "(function(b,i){return b.getFloat64(i,true);})"  getFloat64le :: Get Double getFloat64le =-  Get $ \buf next -> Right (next+8, unsafePerformIO $ getF64le buf next)+  Get $ \buf next -> Ok (next+8) (unsafePerformIO $ getF64le buf next)  getBytes :: Int -> Get BlobData-getBytes len = Get $ \buf next -> Right (next+len, BlobData next len buf)+getBytes len = Get $ \buf next -> Ok (next+len) (BlobData next len buf) +-- | Read a 'JSString' of @n@ characters. Encoding is assumed to be UTF-16.+getJSString :: Word32 -> Get JSString+getJSString len = Get $ \buf next ->+  Ok (next+fromIntegral (len+len)) (unsafePerformIO $ getJSS buf next len)++getJSS :: JSAny -> Int -> Word32 -> IO JSString+getJSS = ffi "(function(b,off,len){return String.fromCharCode.apply(null,new Uint16Array(b.buffer,off,len));})"+ -- | Skip n bytes of input. skip :: Int -> Get ()-skip len = Get $ \buf next -> Right (next+len, ())+skip len = Get $ \_buf next -> Ok (next+len) ()  -- | Run a Get computation. runGet :: Get a -> BlobData -> Either String a runGet (Get p) (BlobData off len bd) = do-    (consumed, x) <- p bd off-    if consumed <= len-      then Right x-      else Left "Not enough data!"+  case p bd off of+    Ok consumed x+      | consumed <= len -> Right x+      | otherwise       -> Left "Not enough data!"+    Fail s              -> Left s  #else @@ -158,6 +167,10 @@ getBytes len = Get $ do   bs <- BG.getLazyByteString (fromIntegral len)   return (BlobData bs)++getJSString :: Int -> Get JSString+getJSString len = Get $ do+  toJSStr `fmap` forM [1..len] (\_ -> fmap (chr . fromIntegral) BG.getWord16le)  -- | Skip n bytes of input. skip :: Int -> Get ()

@@ -4,32 +4,35 @@     putWord8, putWord16le, putWord32le,     putInt8, putInt16le, putInt32le,     putFloat32le, putFloat64le,-    putBlob,+    putBlob, putJSString,     runPut   ) where import Data.Int import Data.Word import Haste.Prim-import Haste.Foreign import Haste.Binary.Types+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif+#ifdef __HASTE__ import Control.Monad+import Haste.Foreign import System.IO.Unsafe-#ifndef __HASTE__+#else+import Data.Char (ord) import qualified Data.Binary as B import qualified Data.Binary.IEEE754 as BI import qualified Data.Binary.Put as BP-import qualified Data.Binary.Put as BP #endif  type Put = PutM ()  #ifdef __HASTE__-type JSArr = Unpacked+type JSArr = JSAny newArr :: IO JSArr newArr = ffi "(function(){return [];})" -push :: Marshal a => JSArr -> a -> IO ()+push :: JSArr -> JSAny -> IO () push = ffi "(function(a,x) {a.push(x);})"  data PutM a = PutM {unP :: JSArr -> IO a}@@ -68,38 +71,51 @@ putFloat32le :: Float -> Put putFloat32le f = PutM $ \a -> push a (unsafePerformIO $ f2ab f) -{-# NOINLINE f2ab #-}-f2ab :: Float -> IO Unpacked+f2ab :: Float -> IO JSAny f2ab = ffi "(function(f) {var a=new ArrayBuffer(4);new DataView(a).setFloat32(0,f,true);return a;})"  putFloat64le :: Double -> Put putFloat64le f = PutM $ \a -> push a (unsafePerformIO $ d2ab f) -{-# NOINLINE d2ab #-}-d2ab :: Double -> IO Unpacked+d2ab :: Double -> IO JSAny d2ab = ffi "(function(f) {var a=new ArrayBuffer(8);new DataView(a).setFloat64(0,f,true);return a;})"  -- | Write a Blob verbatim into the output stream. putBlob :: Blob -> Put-putBlob b = PutM $ \a -> push a (unpack b)+putBlob b = PutM $ \a -> push a (toAny b) -toAB :: Marshal a => JSString -> Int -> a -> Unpacked-toAB view size elem = unsafePerformIO $ toABle view size (unpack elem)+toAB :: ToAny a => JSString -> Int -> a -> JSAny+toAB view size el = unsafePerformIO $ toABle view size (toAny el) -{-# NOINLINE toABle #-}-toABle :: Marshal a => JSString -> Int -> a -> IO Unpacked-toABle = ffi "window['toABle']"+toABle :: ToAny a => JSString -> Int -> a -> IO JSAny+toABle s n x = jsToABle s n (toAny x) +jsToABle :: JSString -> Int -> JSAny -> IO JSAny+jsToABle = ffi "window['toABle']"++-- | Serialize a 'JSString' as UTF-16 (somewhat) efficiently.+putJSString :: JSString -> Put+putJSString s = PutM $ \a -> push a (unsafePerformIO $ str2ab s)++str2ab :: JSString -> IO JSAny+str2ab = ffi "(function(s) {\+  var l = s.length;\+  var v = new Uint16Array(new ArrayBuffer(l*2));\+  for (var i=0; i<l; ++i) {\+    v[i]=s.charCodeAt(i);\+  }\+  return v.buffer;})"+ -- | Run a Put computation. runPut :: Put -> Blob runPut (PutM putEverything) = unsafePerformIO $ do     a <- newArr     putEverything a-    go a-  where-    go :: JSArr -> IO Blob-    go = ffi "(function(parts){return new Blob(parts);})"+    jsGetBlob a +jsGetBlob :: JSArr -> IO Blob+jsGetBlob = ffi "(function(parts){return new Blob(parts);})"+ #else  newtype PutM a = PutM (BP.PutM a) deriving (Functor, Applicative, Monad)@@ -133,5 +149,9 @@  putBlob :: Blob -> Put putBlob (Blob b) = PutM $ BP.putLazyByteString b++-- | Serialize a 'JSString' as UTF-16 (somewhat) efficiently.+putJSString :: JSString -> Put+putJSString = mapM_ (putWord16le . fromIntegral . ord) . fromJSStr  #endif

@@ -5,16 +5,22 @@   ) where import Haste.Prim import Haste.Foreign-import System.IO.Unsafe import qualified Data.ByteString.Lazy as BS #ifndef __HASTE__ import qualified Data.ByteString.UTF8 as BU+#else+import System.IO.Unsafe #endif  #ifdef __HASTE__-data BlobData = BlobData Int Int Unpacked-newtype Blob = Blob Unpacked deriving (Pack, Unpack)+-- | In a browser context, BlobData is essentially a DataView, with an+--   accompanying offset and length for fast slicing.+--   In a server context, it is simply a 'BS.ByteString'.+data BlobData = BlobData Int Int JSAny +-- | A JavaScript Blob on the client, a 'BS.ByteString' on the server.+newtype Blob = Blob JSAny deriving (ToAny, FromAny)+ -- | The size, in bytes, of the contents of the given blob. blobSize :: Blob -> Int blobSize = unsafePerformIO . ffi "(function(b){return b.size;})"@@ -39,28 +45,37 @@  -- | Create a Blob from a JSString. strToBlob :: JSString -> Blob-strToBlob = newBlob . unpack+strToBlob = newBlob . toAny  sliceBlob :: Blob -> Int -> Int -> Blob-sliceBlob b off len = unsafePerformIO $ do-  ffi "(function(b,off,len){return b.slice(off,len);})" b off len+sliceBlob b off len = unsafePerformIO $ jsSlice b off len -newBlob :: Unpacked -> Blob+jsSlice :: Blob -> Int -> Int -> IO Blob+jsSlice = ffi "(function(b,off,len){return b.slice(off,len);})"++newBlob :: JSAny -> Blob newBlob = unsafePerformIO . jsNewBlob -jsNewBlob :: Unpacked -> IO Blob+jsNewBlob :: JSAny -> IO Blob jsNewBlob =   ffi "(function(b){try {return new Blob([b]);} catch (e) {return new Blob([b.buffer]);}})" #else +-- | In a browser context, BlobData is essentially a DataView, with an+--   accompanying offset and length for fast slicing.+--   In a server context, it is simply a 'BS.ByteString'. newtype BlobData = BlobData BS.ByteString++-- | A JavaScript Blob on the client, a 'BS.ByteString' on the server. newtype Blob = Blob BS.ByteString  -- Never used except for type checking-instance Pack BlobData-instance Unpack BlobData-instance Pack Blob-instance Unpack Blob+clientOnly :: a+clientOnly = error "ToAny/FromAny only usable client-side!"+instance ToAny BlobData where toAny = clientOnly+instance FromAny BlobData where fromAny = clientOnly+instance ToAny Blob where toAny = clientOnly+instance FromAny Blob where fromAny = clientOnly  -- | The size, in bytes, of the contents of the given blob. blobSize :: Blob -> Int

@@ -1,158 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, GADTs,-             FlexibleInstances, OverloadedStrings, CPP, MultiParamTypeClasses,-             TypeFamilies, FlexibleContexts #-}-module Haste.Callback (-    GenericCallback (..), toCallback,-    setCallback, setCallback', JSFun (..), mkCallback, Event (..),-    setTimeout, setTimeout', Callback (..), onEvent, onEvent',-    jsSetCB, jsSetTimeout, evtName-  ) where-import Haste.Prim-import Haste.DOM-import Haste.Concurrent.Monad-import Data.String-import Control.Monad.IO.Class--newtype JSFun a = JSFun (Ptr a)--#ifdef __HASTE__-foreign import ccall jsSetCB :: Elem -> JSString -> JSFun a -> IO Bool-foreign import ccall jsSetTimeout :: Int -> JSFun a -> IO ()-#else-jsSetCB :: Elem -> JSString -> JSFun a -> IO Bool-jsSetCB = error "Tried to use jsSetCB on server side!"-jsSetTimeout :: Int -> JSFun a -> IO ()-jsSetTimeout = error "Tried to use jsSetTimeout on server side!"-#endif---- | Turn a function of type a -> ... -> m () into a function of type---   a -> ... -> IO (), for use with generic JS callbacks.-toCallback :: (Monad m, GenericCallback a m) => a -> m (CB a)-toCallback f = do-  iofy <- mkIOfier f-  return $ mkcb iofy f--class GenericCallback a m where-  type CB a-  -- | Build a callback from an IOfier and a function.-  mkcb :: (m () -> IO ()) -> a -> CB a-  -- | Never evaluate the first argument to mkIOfier, it's only there to fix-  --   the types.-  mkIOfier :: a -> m (m () -> IO ())--instance GenericCallback (IO ()) IO where-  type CB (IO ()) = IO ()-  mkcb toIO m = toIO m-  mkIOfier _ = return id--instance GenericCallback b m => GenericCallback (a -> b) m where-  type CB (a -> b) = a -> CB b-  mkcb toIO f = \x -> mkcb toIO (f x)-  mkIOfier f = mkIOfier (f undefined)---- | Turn a computation into a callback that can be passed to a JS---   function.-mkCallback :: a -> JSFun a-mkCallback = JSFun . toPtr--class Callback a where-  constCallback :: IO () -> a--instance Callback (IO ()) where-  constCallback = id--instance Callback (a -> IO ()) where-  constCallback = const---- | These constructors correspond to their namesake DOM events. Mouse related---   callbacks receive the coordinates of the mouse pointer at the time the---   event was fired, relative to the top left corner of the element that fired---   the event. The click events also receive the mouse button that was---   pressed.------   The key up/down/press events receive the character code of the key that---   was pressed.-data Event m a where-  OnLoad      :: Event m (m ())-  OnUnload    :: Event m (m ())-  OnChange    :: Event m (m ())-  OnFocus     :: Event m (m ())-  OnBlur      :: Event m (m ())-  OnMouseMove :: Event m ((Int, Int) -> m ())-  OnMouseOver :: Event m ((Int, Int) -> m ())-  OnMouseOut  :: Event m (m ())-  OnClick     :: Event m (Int -> (Int, Int) -> m ())-  OnDblClick  :: Event m (Int -> (Int, Int) -> m ())-  OnMouseDown :: Event m (Int -> (Int, Int) -> m ())-  OnMouseUp   :: Event m (Int -> (Int, Int) -> m ())-  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--instance Eq (Event m a) where-  a == b = evtName a == (evtName b :: String)--instance Ord (Event m a) where-  compare a b = compare (evtName a) (evtName b :: String)---- | The name of a given event.-evtName :: IsString s => Event m a -> s-evtName evt =-  case evt of-    OnLoad      -> "load"-    OnUnload    -> "unload"-    OnClick     -> "click"-    OnDblClick  -> "dblclick"-    OnMouseDown -> "mousedown"-    OnMouseUp   -> "mouseup"-    OnMouseMove -> "mousemove"-    OnMouseOver -> "mouseover"-    OnMouseOut  -> "mouseout"-    OnKeyPress  -> "keypress"-    OnKeyUp     -> "keyup"-    OnKeyDown   -> "keydown"-    OnChange    -> "change"-    OnFocus     -> "focus"-    OnBlur      -> "blur"-    OnSubmit    -> "submit"-    OnWheel     -> "wheel"---- | Friendlier name for @setCallback@.-onEvent :: MonadIO m => Elem -> Event IO a -> a -> m Bool-onEvent = setCallback---- | Friendlier name for @setCallback'@.-onEvent' :: (ToConcurrent a, MonadIO m) => Elem -> Event CIO a -> Async a -> m Bool-onEvent' = setCallback'---- | Set a callback for the given event.-setCallback :: MonadIO m => Elem -> Event IO a -> a -> m Bool-setCallback e evt f =-  liftIO $ jsSetCB e (evtName evt) (mkCallback $! f)---- | Like @setCallback@, but takes a callback in the CIO monad instead of IO.-setCallback' :: (ToConcurrent a, MonadIO m)-             => Elem-             -> Event CIO a-             -> Async a-             -> m Bool-setCallback' e evt f =-    liftIO $ jsSetCB e (evtName evt) (mkCallback $! f')-  where-    f' = asEvtTypeOf evt (async f)---- | Wrapper for window.setTimeout; execute the given computation after a delay---   given in milliseconds.-setTimeout :: MonadIO m => Int -> IO () -> m ()-setTimeout delay cb =-  liftIO $ jsSetTimeout delay (mkCallback $! cb)---- | Like 'setTimeout', but takes a callback in the CIO monad instead of IO.-setTimeout' :: MonadIO m => Int -> CIO () -> m ()-setTimeout' delay cb =-  liftIO $ jsSetTimeout delay (mkCallback $! concurrent cb)

@@ -13,7 +13,6 @@ #ifndef __HASTE__ import Control.Shell import Haste.Environment-import Data.Maybe import Data.List (intercalate) #endif @@ -29,25 +28,25 @@ compile _ _ _ = return $ Failure "Haste can only compile programs server-side." #else compile cf dir inp = do-  res <- shell $ do+  eresult <- shell $ do     curdir <- pwd     inTempDirectory $ do-      f <- case inp of+      fil <- case inp of         InFile f   -> return $ if isRelative f then incdir curdir </> f else f         InString s -> file "Main.hs" s >>= \() -> return "Main.hs"-      (f, o, e) <- genericRun hasteBinary (f : idir curdir : mkFlags cf) ""+      (f,_,e) <- genericRun hasteBinary (fil : idir curdir : mkFlags cf) ""       if not f         then do           return $ Failure e         else do           case cfTarget cf of-            TargetFile f -> do-              return $ Success $ OutFile f+            TargetFile tgt -> do+              return $ Success $ OutFile tgt             TargetString -> do               (Success . OutString) `fmap` file "haste.out"-  case res of-    Right res ->-      return res+  case eresult of+    Right result ->+      return result     Left e ->       return $ Failure $ "Run-time failure during compilation: " ++ e   where@@ -56,25 +55,30 @@  -- | Turn flags into command line argument. mkFlags :: CompileFlags -> [String]-mkFlags cf = catMaybes [+mkFlags cf = concat [     case cfOptimize cf of-      None         -> Just "-O0"-      Basic        -> Nothing-      WholeProgram -> Just "--opt-whole-program",+      None         -> ["-O0", "--ddisable-js-opts"]+      Basic        -> []+      WholeProgram -> ["--opt-whole-program"],     case cfStart cf of-      ASAP     -> Just "--start=asap"-      OnLoad   -> Nothing-      Custom s -> Just $ "--start=" ++ s,+      ASAP     -> ["--onexec"]+      OnLoad   -> ["--onload"]+      Custom s -> ["--start=" ++ s],     case cfTarget cf of-      TargetFile fp -> Just $ "--out=" ++ fp-      TargetString  -> Just $ "--out=haste.out",+      TargetFile fp -> ["--out=" ++ fp]+      TargetString  -> ["--out=haste.out"],+    case cfMinify cf of+      DontMinify         -> []+      Minify (Just p) fs -> ("--opt-minify="++p) : map appendMinifyFlag fs+      Minify _ fs        -> "--opt-minify" : map appendMinifyFlag fs,     when cfDebug        "--debug",-    when cfMinify       "--opt-google-closure",     when cfFullUnicode  "--full-unicode",     when cfOwnNamespace "--separate-namespace",-    when (not . null . cfJSFiles) ("--with-js=" ++ jsFileList)+    when (not . null . cfJSFiles) ("--with-js=" ++ jsFileList),+    when (not . cfUseStrict) "--no-use-strict"   ]   where+    appendMinifyFlag f = "--opt-minify-flag=" ++ f     jsFileList = intercalate "," $ cfJSFiles cf-    when opt arg = if opt cf then Just arg else Nothing+    when opt arg = if opt cf then [arg] else [] #endif

@@ -1,10 +1,13 @@ module Haste.Compiler.Flags (-    OptLevel (..), ProgStart (..), HasteTarget (..), CompileFlags,+    OptLevel (..), ProgStart (..), HasteTarget (..), MinifyFlag (..),+    ClosureOpt,+    CompileFlags,+    defaultFlags,     cfOptimize, cfDebug, cfMinify, cfFullUnicode, cfOwnNamespace, cfStart,-    cfJSFiles, cfTarget+    cfJSFiles, cfTarget, cfUseStrict   ) where-import Data.Default-+type ClosureOpt = String+data MinifyFlag = DontMinify | Minify (Maybe FilePath) [ClosureOpt] data OptLevel = None | Basic | WholeProgram data ProgStart = ASAP | OnLoad | Custom String data HasteTarget = TargetFile FilePath | TargetString@@ -22,7 +25,7 @@     -- | Should the program be minified? This will strip any debug information     --   from the resulting program.     --   Default: False-    cfMinify       :: Bool,+    cfMinify       :: MinifyFlag,     -- | Use full Unicode compatibility for Data.Char and friends?     --   Default: False     cfFullUnicode  :: Bool,@@ -37,17 +40,22 @@     cfJSFiles      :: [FilePath],     -- | Where to place the compilation output.     --   Default: TargetString-    cfTarget       :: HasteTarget+    cfTarget       :: HasteTarget,+    -- | @'use strict';@?+    --   Default: True+    cfUseStrict    :: Bool   } -instance Default CompileFlags where-  def = CompileFlags {-      cfOptimize = Basic,-      cfDebug = False,-      cfMinify = False,-      cfFullUnicode = False,-      cfOwnNamespace = False,-      cfStart = OnLoad,-      cfJSFiles = [],-      cfTarget = TargetString-    }+-- | Default compiler flags.+defaultFlags :: CompileFlags+defaultFlags = CompileFlags {+    cfOptimize = Basic,+    cfDebug = False,+    cfMinify = DontMinify,+    cfFullUnicode = False,+    cfOwnNamespace = False,+    cfStart = OnLoad,+    cfJSFiles = [],+    cfTarget = TargetString,+    cfUseStrict = True+  }

@@ -8,20 +8,15 @@     wait   ) where import Haste.Concurrent.Monad-import Haste.Concurrent.Ajax as Ajax hiding ((!))-import Haste.Callback+import Haste.Concurrent.Ajax as Ajax+import Haste.Timer  -- | Wait for n milliseconds. wait :: Int -> CIO () wait ms = do   v <- newEmptyMVar-  liftIO $ setTimeout' ms $ putMVar v ()+  _ <- liftIO $ setTimer (Once ms) $ concurrent $ putMVar v ()   takeMVar v--instance GenericCallback (CIO ()) CIO where-  type CB (CIO ()) = IO ()-  mkcb toIO m = toIO m-  mkIOfier _ = return concurrent  -- | An MBox is a read/write-only MVar, depending on its first type parameter. --   Used to communicate with server processes.

@@ -1,48 +1,23 @@ {-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-} -- | Concurrent Ajax calls. IE6 and older are not supported. module Haste.Concurrent.Ajax (-    Key, Val, JSON (..), (!), (~>), Method (..), URL, AjaxData (..),-    ajaxRequest+    Method (..), URL, noParams,+    Haste.Concurrent.Ajax.ajaxRequest   ) where import Haste.Concurrent.Monad import Haste.Ajax import Haste.JSType-import Haste.JSON-import Haste.Prim (JSString) --- | Data that can be received from an AJAX call.-class AjaxData a where-  encode :: a -> JSString-  decode :: JSString -> Maybe a--instance JSType a => AjaxData a where-  encode = toJSString-  decode = fromJSString--instance AjaxData JSON where-  encode = encodeJSON-  decode x =-    case decodeJSON x of-      Right x' -> Just x'-      _        -> Nothing---- | Make an Ajax GET request to a URL. The function will block until a---   response is received.-ajaxRequest :: AjaxData a-            => URL          -- ^ Base URL to call. The query string generated-                            --   from the second argument will be appended to-                            --   this to construct the final URL.-            -> [(Key, Val)] -- ^ Key value pairs to construct the query part-                            --   of the URL from.-                            --   Passing @[("foo","0"), ("bar", "1")]@ will-                            --   result in a request URL that ends with-                            --   @?foo=0&bar=1@.-            -> CIO (Maybe a)-ajaxRequest url querypart = do-    v <- newEmptyMVar-    let cb x = concurrent $ putMVar v $ x >>= decode-    liftIO $ textRequest_ GET url' querypart' cb-    takeMVar v-  where-    url' = toJSString url-    querypart' = [(toJSString k, toJSString v) | (k, v) <- querypart]+-- | Make a blocking AJAX request in the CIO monad.+--   Note that unlike using the browser's native blocking AJAX facilities,+--   this does *not* freeze the browser.+ajaxRequest :: (JSType a, JSType b, JSType c)+            => Method   -- ^ GET or POST. For GET, pass all params in URL.+                        --   For POST, pass all params as post data.+            -> URL      -- ^ URL to make AJAX request to.+            -> [(a, b)] -- ^ A list of (key, value) parameters.+            -> CIO (Maybe c)+ajaxRequest method url kv = do+  v <- newEmptyMVar+  liftIO $ Haste.Ajax.ajaxRequest method url kv $ concurrent . putMVar v+  takeMVar v

@@ -8,8 +8,11 @@ import Control.Monad.IO.Class import Control.Monad.Cont.Class import Control.Monad+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Data.IORef+import Haste.Events.Core (MonadEvent (..))  -- | Any monad which supports concurrency. class Monad m => MonadConc m where@@ -20,6 +23,9 @@   liftConc = id   fork = forkIO +instance MonadEvent CIO where+  mkHandler = return . fmap concurrent+ -- | Embed concurrent computations into non-concurrent ones. class ToConcurrent a where   type Async a@@ -152,7 +158,6 @@ --   share MVars; if this is the case, then a call to `concurrent` may return --   before all the threads it spawned finish executing. concurrent :: CIO () -> IO ()-#ifdef __HASTE__ concurrent (C m) = scheduler [m (const Stop)]   where     scheduler (p:ps) =@@ -166,6 +171,3 @@           scheduler ps     scheduler _ =       return ()-#else-concurrent = error "concurrent called in a non-browser environment!"-#endif

@@ -1,33 +1,25 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP,-             GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-}+-- | DOM manipulation functions using 'String' for string representation. module Haste.DOM (-    Elem (..), PropID, ElemID, QuerySelector, ElemClass,-    Attribute, AttrName, AttrValue,-    set, style, attr, with, (=:),+    module Core,+    IsElem (..), Elem, PropID, ElemID, QuerySelector, ElemClass,+    AttrName, AttrValue,+    style, attr, (=:),     newElem, newTextElem,     elemById, elemsByQS, elemsByClass,-    setProp, getProp, setAttr, getAttr, setProp', getProp', getValue,+    setProp, getProp, setAttr, getAttr, J.getValue,     withElem , withElems, withElemsQS, mapQS, mapQS_,-    addChild, addChildBefore, removeChild, clearChildren , getChildBefore,-    getFirstChild, getLastChild, getChildren, setChildren,-    getStyle, setStyle, getStyle', setStyle',-    getFileData, getFileName,-    setClass, toggleClass, hasClass,-    click, focus, blur,-    document, documentBody+    getStyle, setStyle,+    J.getFileData, getFileName,+    setClass, toggleClass, hasClass   ) where-import Haste.Prim-import Haste.JSType-import Data.Maybe (isNothing, fromJust)+import qualified Haste.DOM.JSString as J+import qualified Haste.DOM.Core as Core+  hiding (Elem (..), AttrName (..))+import Haste.DOM.Core+import Haste.Prim (fromJSStr, toJSStr) import Control.Monad.IO.Class-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)- type PropID = String type ElemID = String type QuerySelector = String@@ -46,319 +38,98 @@ (=:) :: 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 ()-foreign import ccall jsGetAttr :: Elem -> JSString -> IO JSString-foreign import ccall jsSetAttr :: Elem -> JSString -> JSString -> IO ()-foreign import ccall jsGetStyle :: Elem -> JSString -> IO JSString-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 ()-foreign import ccall jsGetFirstChild :: Elem -> IO (Ptr (Maybe Elem))-foreign import ccall jsGetLastChild :: Elem -> IO (Ptr (Maybe Elem))-foreign import ccall jsGetChildren :: Elem -> IO (Ptr [Elem])-foreign import ccall jsSetChildren :: Elem -> Ptr [Elem] -> IO ()-foreign import ccall jsAddChildBefore :: Elem -> Elem -> Elem -> IO ()-foreign import ccall jsGetChildBefore :: Elem -> IO (Ptr (Maybe Elem))-foreign import ccall jsKillChild :: Elem -> Elem -> IO ()-foreign import ccall jsClearChildren :: Elem -> IO ()-#else-jsGet = error "Tried to use jsGet on server side!"-jsSet = error "Tried to use jsSet on server side!"-jsGetAttr = error "Tried to use jsGetAttr on server side!"-jsSetAttr = error "Tried to use jsSetAttr on server side!"-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!"-jsAppendChild = error "Tried to use jsAppendChild on server side!"-jsGetFirstChild = error "Tried to use jsGetFirstChild on server side!"-jsGetLastChild = error "Tried to use jsGetLastChild on server side!"-jsGetChildren = error "Tried to use jsGetChildren on server side!"-jsSetChildren = error "Tried to use jsSetChildren on server side!"-jsAddChildBefore = error "Tried to use jsAddChildBefore on server side!"-jsGetChildBefore = error "Tried to use jsGetChildBefore on server side!"-jsKillChild = error "Tried to use jsKillChild on server side!"-jsClearChildren = error "Tried to use jsClearChildren on server side!"-#endif---- | Append the first element as a child of the second element.-addChild :: MonadIO m => Elem -> Elem -> m ()-addChild child parent = liftIO $ jsAppendChild child parent---- | Insert the first element as a child into the second, before the third.---   For instance:--- @---   addChildBefore childToAdd theContainer olderChild--- @-addChildBefore :: MonadIO m => Elem -> Elem -> Elem -> m ()-addChildBefore child parent oldChild =-  liftIO $ jsAddChildBefore child parent oldChild---- | Get the sibling before the given one, if any.-getChildBefore :: MonadIO m => Elem -> m (Maybe Elem)-getChildBefore e = liftIO $ fromPtr `fmap` jsGetChildBefore e---- | Get the first of an element's children.-getFirstChild :: MonadIO m => Elem -> m (Maybe Elem)-getFirstChild e = liftIO $ fromPtr `fmap` jsGetFirstChild e---- | Get the last of an element's children.-getLastChild :: MonadIO m => Elem -> m (Maybe Elem)-getLastChild e = liftIO $ fromPtr `fmap` jsGetLastChild e---- | Get a list of all children belonging to a certain element.-getChildren :: MonadIO m => Elem -> m [Elem]-getChildren e = liftIO $ fromPtr `fmap` jsGetChildren e---- | Clear the given element's list of children, and append all given children---   to it.-setChildren :: MonadIO m => Elem -> [Elem] -> m ()-setChildren e ch = liftIO $ jsSetChildren e (toPtr ch)- -- | Create an element. newElem :: MonadIO m => String -> m Elem-newElem = liftIO . jsCreateElem . toJSStr+newElem = J.newElem . toJSStr  -- | Create a text node. newTextElem :: MonadIO m => String -> m Elem-newTextElem = liftIO . jsCreateTextNode . toJSStr+newTextElem = J.newTextElem . toJSStr  -- | Set a property of the given element.-setProp :: MonadIO m => Elem -> PropID -> String -> m ()-setProp e prop val = liftIO $ jsSet e (toJSStr prop) (toJSStr val)---- | Set a property of the given element, JSString edition.-setProp' :: MonadIO m => Elem -> JSString -> JSString -> m ()-setProp' e prop val = liftIO $ jsSet e prop val+setProp :: (IsElem e, MonadIO m) => e -> PropID -> String -> m ()+setProp e prop val = J.setProp e (toJSStr prop) (toJSStr val)  -- | Set an attribute of the given element.-setAttr :: MonadIO m => Elem -> PropID -> String -> m ()-setAttr e prop val = liftIO $ jsSetAttr e (toJSStr prop) (toJSStr val)---- | Get the value property of an element; a handy shortcut.-getValue :: (MonadIO m, JSType a) => Elem -> m (Maybe a)-getValue e = liftIO $ fromJSString `fmap` jsGet e "value"+setAttr :: (IsElem e, MonadIO m) => e -> PropID -> String -> m ()+setAttr e prop val = J.setAttr e (toJSStr prop) (toJSStr val)  -- | Get a property of an element.-getProp :: MonadIO m => Elem -> PropID -> m String-getProp e prop = liftIO $ fromJSStr `fmap` jsGet e (toJSStr prop)---- | Get a property of an element, JSString edition.-getProp' :: MonadIO m => Elem -> JSString -> m JSString-getProp' e prop = liftIO $ jsGet e prop+getProp :: (IsElem e, MonadIO m) => e -> PropID -> m String+getProp e prop = J.getProp e (toJSStr prop) >>= return . fromJSStr  -- | Get an attribute of an element.-getAttr :: MonadIO m => Elem -> PropID -> m String-getAttr e prop = liftIO $ fromJSStr `fmap` jsGetAttr e (toJSStr prop)+getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m String+getAttr e prop = J.getAttr e (toJSStr prop) >>= return . fromJSStr  -- | Get a CSS style property of an element.-getStyle :: MonadIO m => Elem -> PropID -> m String-getStyle e prop = liftIO $ fromJSStr `fmap` jsGetStyle e (toJSStr prop)---- | Get a CSS style property of an element, JSString style.-getStyle' :: MonadIO m => Elem -> JSString -> m JSString-getStyle' e prop = liftIO $ jsGetStyle e prop+getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m String+getStyle e prop = J.getStyle e (toJSStr prop) >>= return . fromJSStr  -- | Set a CSS style property on an element.-setStyle :: MonadIO m => Elem -> PropID -> String -> m ()-setStyle e prop val = liftIO $ jsSetStyle e (toJSStr prop) (toJSStr val)---- | Set a CSS style property on an element, JSString style.-setStyle' :: MonadIO m => Elem -> JSString -> JSString -> m ()-setStyle' e prop val = liftIO $ jsSetStyle e prop val+setStyle :: (IsElem e, MonadIO m) => e -> PropID -> String -> m ()+setStyle e prop val = J.setStyle e (toJSStr prop) (toJSStr val)  -- | Get an element by its HTML ID attribute. elemById :: MonadIO m => ElemID -> m (Maybe Elem)-elemById eid = liftIO $ fromPtr `fmap` (jsFind $ toJSStr eid)+elemById = J.elemById . toJSStr  -- | Get all elements of the given class. elemsByClass :: MonadIO m => ElemClass -> m [Elem]-elemsByClass cls = liftIO $ fromPtr `fmap` (jsElemsByClassName (toJSStr cls))+elemsByClass = J.elemsByClass . toJSStr  -- | 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))+elemsByQS el = J.elemsByQS el . toJSStr  -- | Perform an IO action on an element. withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a-withElem e act = do-  me' <- elemById e-  case me' of-    Just e' -> act e'-    _       -> error $ "No element with ID " ++ e ++ " could be found!"+withElem = J.withElem . toJSStr  -- | Perform an IO action over several elements. Throws an error if some of the --   elements are not found. withElems :: MonadIO m => [ElemID] -> ([Elem] -> m a) -> m a-withElems es act = do-    mes <- mapM elemById es-    if any isNothing mes-      then error $ "Elements with the following IDs could not be found: "-                 ++ show (findElems es mes)-      else act $ map fromJust mes-  where-    findElems (i:is) (Nothing:mes) = i : findElems is mes-    findElems (_:is) (_:mes)       = findElems is mes-    findElems _ _                  = []+withElems = J.withElems . map toJSStr  -- | Perform an IO action over the a list of elements matching a query --   selector.-withElemsQS :: MonadIO m => Elem -> QuerySelector -> ([Elem] -> m a) -> m a-withElemsQS el sel act = elemsByQS el sel >>= act+withElemsQS :: (IsElem e, MonadIO m)+            => e+            -> QuerySelector+            -> ([Elem] -> m a)+            -> m a+withElemsQS el = J.withElemsQS el . toJSStr  -- | Map an IO computation over the list of elements matching a query selector.-mapQS :: MonadIO m => Elem -> QuerySelector -> (Elem -> m a) -> m [a]-mapQS el sel act = elemsByQS el sel >>= mapM act+mapQS :: (IsElem e, MonadIO m)+      => e+      -> QuerySelector+      -> (Elem -> m a)+      -> m [a]+mapQS el = J.mapQS el . toJSStr  -- | Like @mapQS@ but returns no value.-mapQS_ :: MonadIO m => Elem -> QuerySelector -> (Elem -> m a) -> m ()-mapQS_ el sel act = elemsByQS el sel >>= mapM_ act---- | Remove all children from the given element.-clearChildren :: MonadIO m => Elem -> m ()-clearChildren = liftIO . jsClearChildren---- | Remove the first element from the second's children.-removeChild :: MonadIO m => Elem -> Elem -> m ()-removeChild child parent = liftIO $ jsKillChild child parent---- | Get a file from a file input element.-getFileData :: MonadIO m => Elem -> Int -> m (Maybe Blob)-getFileData e ix = liftIO $ do-    num <- getFiles e-    if ix < num-      then Just `fmap` getFile e ix-      else return Nothing-  where-    {-# NOINLINE getFiles #-}-    getFiles :: Elem -> IO Int-    getFiles = ffi "(function(e){return e.files.length;})"-    {-# NOINLINE getFile #-}-    getFile :: Elem -> Int -> IO Blob-    getFile = ffi "(function(e,ix){return e.files[ix];})"+mapQS_ :: (IsElem e, MonadIO m)+       => e+       -> QuerySelector+       -> (Elem -> m a)+       -> m ()+mapQS_ el = J.mapQS_ el . toJSStr  -- | Get the name of the currently selected file from a file input element. --   Any directory information is stripped, and only the actual file name is --   returned, as the directory information is useless (and faked) anyway.-getFileName :: MonadIO m => Elem -> m String-getFileName e = liftIO $ do-    fn <- getProp e "value"-    return $ reverse $ takeWhile (not . separator) $ reverse fn-  where-    separator '/'  = True-    separator '\\' = True-    separator _    = False+getFileName :: (IsElem e, MonadIO m) => e -> m String+getFileName e = J.getFileName e >>= return . fromJSStr  -- | Add or remove a class from an element's class list.-setClass :: MonadIO m => Elem -> String -> Bool -> m ()-setClass e c x = liftIO $ setc e c x-  where-    {-# NOINLINE setc #-}-    setc :: Elem -> String -> Bool -> IO ()-    setc = ffi "(function(e,c,x){x?e.classList.add(c):e.classList.remove(c);})"+setClass :: (IsElem e, MonadIO m) => e -> String -> Bool -> m ()+setClass e sel = J.setClass e (toJSStr sel)  -- | Toggle the existence of a class within an elements class list.-toggleClass :: MonadIO m => Elem -> String -> m ()-toggleClass e c = liftIO $ toggc e c-  where-    {-# NOINLINE toggc #-}-    toggc :: Elem -> String -> IO ()-    toggc = ffi "(function(e,c) {e.classList.toggle(c);})"+toggleClass :: (IsElem e, MonadIO m) => e -> String -> m ()+toggleClass e = J.toggleClass e . toJSStr  -- | Does the given element have a particular class?-hasClass :: MonadIO m => Elem -> String -> m Bool-hasClass e c = liftIO $ getc e c-  where-    {-# NOINLINE getc #-}-    getc :: Elem -> String -> IO Bool-    getc = ffi "(function(e,c) {return e.classList.contains(c);})"---- | Generate a click event on an element.-click :: MonadIO m => Elem -> m ()-click = liftIO . click'-  where-    {-# NOINLINE click' #-}-    click' :: Elem -> IO ()-    click' = ffi "(function(e) {e.click();})"---- | Generate a focus event on an element.-focus :: MonadIO m => Elem -> m ()-focus = liftIO . focus'-  where-    {-# NOINLINE focus' #-}-    focus' :: Elem -> IO ()-    focus' = ffi "(function(e) {e.focus();})"---- | Generate a blur event on an element.-blur :: MonadIO m => Elem -> m ()-blur = liftIO . blur'-  where-    {-# NOINLINE blur' #-}-    blur' :: Elem -> IO ()-    blur' = ffi "(function(e) {e.blur();})"---- | The DOM node corresponding to document.-document :: Elem-document = unsafePerformIO getDocument-  where-    {-# NOINLINE getDocument #-}-    getDocument :: IO Elem-    getDocument = ffi "document"---- | The DOM node corresponding to document.body.-documentBody :: Elem-documentBody = unsafePerformIO getBody-  where-    {-# 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+hasClass :: (IsElem e, MonadIO m) => e -> String -> m Bool+hasClass e = J.hasClass e . toJSStr

@@ -0,0 +1,226 @@+{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving,+             OverloadedStrings #-}+-- | Core types and operations for DOM manipulation.+module Haste.DOM.Core (+    Elem (..), IsElem (..), Attribute, AttrName (..),+    set, with, attribute, children,+    click, focus, blur,+    document, documentBody,+    deleteChild, clearChildren,+    setChildren, getChildren,+    getLastChild, getFirstChild, getChildBefore,+    insertChildBefore, appendChild,+    -- Deprecated+    removeChild, addChild, addChildBefore+  ) where+import Haste.Prim+import Control.Monad.IO.Class+import Haste.Foreign+import Data.String++#ifdef __HASTE__+foreign import ccall jsSet :: Elem -> JSString -> JSString -> IO ()+foreign import ccall jsSetAttr :: Elem -> JSString -> JSString -> IO ()+foreign import ccall jsSetStyle :: Elem -> JSString -> JSString -> IO ()+foreign import ccall jsAppendChild :: Elem -> Elem -> IO ()+foreign import ccall jsGetFirstChild :: Elem -> IO (Ptr (Maybe Elem))+foreign import ccall jsGetLastChild :: Elem -> IO (Ptr (Maybe Elem))+foreign import ccall jsGetChildren :: Elem -> IO (Ptr [Elem])+foreign import ccall jsSetChildren :: Elem -> Ptr [Elem] -> IO ()+foreign import ccall jsAddChildBefore :: Elem -> Elem -> Elem -> IO ()+foreign import ccall jsGetChildBefore :: Elem -> IO (Ptr (Maybe Elem))+foreign import ccall jsKillChild :: Elem -> Elem -> IO ()+foreign import ccall jsClearChildren :: Elem -> IO ()+#else+jsSet :: Elem -> JSString -> JSString -> IO ()+jsSet = error "Tried to use jsSet on server side!"+jsSetAttr :: Elem -> JSString -> JSString -> IO ()+jsSetAttr = error "Tried to use jsSetAttr on server side!"+jsSetStyle :: Elem -> JSString -> JSString -> IO ()+jsSetStyle = error "Tried to use jsSetStyle on server side!"+jsAppendChild :: Elem -> Elem -> IO ()+jsAppendChild = error "Tried to use jsAppendChild on server side!"+jsGetFirstChild :: Elem -> IO (Ptr (Maybe Elem))+jsGetFirstChild = error "Tried to use jsGetFirstChild on server side!"+jsGetLastChild :: Elem -> IO (Ptr (Maybe Elem))+jsGetLastChild = error "Tried to use jsGetLastChild on server side!"+jsGetChildren :: Elem -> IO (Ptr [Elem])+jsGetChildren = error "Tried to use jsGetChildren on server side!"+jsSetChildren :: Elem -> Ptr [Elem] -> IO ()+jsSetChildren = error "Tried to use jsSetChildren on server side!"+jsAddChildBefore :: Elem -> Elem -> Elem -> IO ()+jsAddChildBefore = error "Tried to use jsAddChildBefore on server side!"+jsGetChildBefore :: Elem -> IO (Ptr (Maybe Elem))+jsGetChildBefore = error "Tried to use jsGetChildBefore on server side!"+jsKillChild :: Elem -> Elem -> IO ()+jsKillChild = error "Tried to use jsKillChild on server side!"+jsClearChildren :: Elem -> IO ()+jsClearChildren = error "Tried to use jsClearChildren on server side!"+#endif++-- | A DOM node.+newtype Elem = Elem JSAny+  deriving (ToAny, FromAny)++-- | The class of types backed by DOM elements.+class IsElem a where+  -- | Get the element representing the object.+  elemOf :: a -> Elem++  -- | Attempt to create an object from an 'Elem'.+  fromElem :: Elem -> IO (Maybe a)+  fromElem = const $ return Nothing++instance IsElem Elem where+  elemOf = id+  fromElem = return . Just++-- | 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 IsString AttrName where+  fromString = PropName . fromString++-- | A key/value pair representing the value of an attribute.+--   May represent a property, an HTML attribute, a style attribute or a list+--   of child elements.+data Attribute+  = Attribute !AttrName !JSString+  | Children ![Elem]++-- | Construct an 'Attribute'.+attribute :: AttrName -> JSString -> Attribute+attribute = Attribute++-- | Set a number of 'Attribute's on an element.+set :: (IsElem e, MonadIO m) => e -> [Attribute] -> m ()+set e as =+    liftIO $ mapM_ set' as+  where+    e' = elemOf e+    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' (Children cs)               = mapM_ (flip jsAppendChild e') cs++-- | Attribute adding a list of child nodes to an element.+children :: [Elem] -> Attribute+children = Children++-- | 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 :: (IsElem e, MonadIO m) => m e -> [Attribute] -> m e+with m attrs = do+  x <- m+  set x attrs+  return x++-- | Generate a click event on an element.+click :: (IsElem e, MonadIO m) => e -> m ()+click = liftIO . click' . elemOf+  where+    {-# NOINLINE click' #-}+    click' :: Elem -> IO ()+    click' = ffi "(function(e) {e.click();})"++-- | Generate a focus event on an element.+focus :: (IsElem e, MonadIO m) => e -> m ()+focus = liftIO . focus' . elemOf+  where+    {-# NOINLINE focus' #-}+    focus' :: Elem -> IO ()+    focus' = ffi "(function(e) {e.focus();})"++-- | Generate a blur event on an element.+blur :: (IsElem e, MonadIO m) => e -> m ()+blur = liftIO . blur' . elemOf+  where+    {-# NOINLINE blur' #-}+    blur' :: Elem -> IO ()+    blur' = ffi "(function(e) {e.blur();})"++-- | The DOM node corresponding to document.+document :: Elem+document = constant "document"++-- | The DOM node corresponding to document.body.+documentBody :: Elem+documentBody = constant "document.body"++-- | Append the first element as a child of the second element.+appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m ()+appendChild parent child = liftIO $ jsAppendChild (elemOf child) (elemOf parent)++{-# DEPRECATED addChild "Use appendChild instead" #-}+-- | DEPRECATED: use 'appendChild' instead!+addChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m ()+addChild = flip appendChild++-- | Insert an element into a container, before another element.+--   For instance:+-- @+--   insertChildBefore theContainer olderChild childToAdd+-- @+insertChildBefore :: (IsElem parent, IsElem before, IsElem child, MonadIO m)+               => parent -> before -> child -> m ()+insertChildBefore parent oldChild child =+  liftIO $ jsAddChildBefore (elemOf child) (elemOf parent) (elemOf oldChild)++{-# DEPRECATED addChildBefore "Use insertChildBefore instead" #-}+-- | DEPRECATED: use 'insertChildBefore' instead!+addChildBefore :: (IsElem parent, IsElem child, MonadIO m)+               => child -> parent -> child -> m ()+addChildBefore child parent oldChild = insertChildBefore parent oldChild child++-- | Get the sibling before the given one, if any.+getChildBefore :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)+getChildBefore e = liftIO $ fromPtr `fmap` jsGetChildBefore (elemOf e)++-- | Get the first of an element's children.+getFirstChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)+getFirstChild e = liftIO $ fromPtr `fmap` jsGetFirstChild (elemOf e)++-- | Get the last of an element's children.+getLastChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)+getLastChild e = liftIO $ fromPtr `fmap` jsGetLastChild (elemOf e)++-- | Get a list of all children belonging to a certain element.+getChildren :: (IsElem e, MonadIO m) => e -> m [Elem]+getChildren e = liftIO $ fromPtr `fmap` jsGetChildren (elemOf e)++-- | Clear the given element's list of children, and append all given children+--   to it.+setChildren :: (IsElem parent, IsElem child, MonadIO m)+            => parent+            -> [child]+            -> m ()+setChildren e ch = liftIO $ jsSetChildren (elemOf e) (toPtr $ map elemOf ch)++-- | Remove all children from the given element.+clearChildren :: (IsElem e, MonadIO m) => e -> m ()+clearChildren = liftIO . jsClearChildren . elemOf++-- | Remove the second element from the first's children.+deleteChild :: (IsElem parent, IsElem child, MonadIO m)+            => parent+            -> child+            -> m ()+deleteChild parent child = liftIO $ jsKillChild (elemOf child) (elemOf parent)++{-# DEPRECATED removeChild "Use deleteChild instead" #-}+-- | DEPRECATED: use 'deleteChild' instead!+removeChild :: (IsElem parent, IsElem child, MonadIO m)+            => child+            -> parent+            -> m ()+removeChild child parent = liftIO $ jsKillChild (elemOf child) (elemOf parent)

@@ -0,0 +1,213 @@+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP #-}+-- | DOM manipulation functions using 'JSString' for string representation.+module Haste.DOM.JSString (+    module Core,+    IsElem (..), Elem, PropID, ElemID, QuerySelector, ElemClass,+    AttrName, AttrValue,+    style, attr, (=:),+    newElem, newTextElem,+    elemById, elemsByQS, elemsByClass,+    setProp, getProp, setAttr, getAttr, getValue,+    withElem , withElems, withElemsQS, mapQS, mapQS_,+    getStyle, setStyle,+    getFileData, getFileName,+    setClass, toggleClass, hasClass+  ) where+import Haste.Prim+import Haste.JSType+import qualified Haste.DOM.Core as Core+  hiding (Elem (..), AttrName (..))+import Haste.DOM.Core+import Data.Maybe (isNothing, fromJust)+import Control.Monad.IO.Class+import Haste.Foreign+import Haste.Binary.Types++type PropID = JSString+type ElemID = JSString+type QuerySelector = JSString+type ElemClass = JSString+type AttrValue = JSString++#ifdef __HASTE__+foreign import ccall jsGet :: Elem -> JSString -> IO JSString+foreign import ccall jsSet :: Elem -> JSString -> JSString -> IO ()+foreign import ccall jsGetAttr :: Elem -> JSString -> IO JSString+foreign import ccall jsSetAttr :: Elem -> JSString -> JSString -> IO ()+foreign import ccall jsGetStyle :: Elem -> JSString -> IO JSString+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+#else+jsGet :: Elem -> JSString -> IO JSString+jsGet = error "Tried to use jsGet on server side!"+jsSet :: Elem -> JSString -> JSString -> IO ()+jsSet = error "Tried to use jsSet on server side!"+jsGetAttr :: Elem -> JSString -> IO JSString+jsGetAttr = error "Tried to use jsGetAttr on server side!"+jsSetAttr :: Elem -> JSString -> JSString -> IO ()+jsSetAttr = error "Tried to use jsSetAttr on server side!"+jsGetStyle :: Elem -> JSString -> IO JSString+jsGetStyle = error "Tried to use jsGetStyle on server side!"+jsSetStyle :: Elem -> JSString -> JSString -> IO ()+jsSetStyle = error "Tried to use jsSetStyle on server side!"+jsFind :: JSString -> IO (Ptr (Maybe Elem))+jsFind = error "Tried to use jsFind on server side!"+jsQuerySelectorAll :: Elem -> JSString -> IO (Ptr [Elem])+jsQuerySelectorAll = error "Tried to use jsQuerySelectorAll on server side!"+jsElemsByClassName :: JSString -> IO (Ptr [Elem])+jsElemsByClassName = error "Tried to use jsElemsByClassName on server side!"+jsCreateElem :: JSString -> IO Elem+jsCreateElem = error "Tried to use jsCreateElem on server side!"+jsCreateTextNode :: JSString -> IO Elem+jsCreateTextNode = error "Tried to use jsCreateTextNode on server side!"+#endif++-- | Create a style attribute name.+style :: JSString -> AttrName+style = StyleName++-- | Create an HTML attribute name.+attr :: JSString -> AttrName+attr = AttrName++-- | Create an 'Attribute'.+(=:) :: AttrName -> AttrValue -> Attribute+(=:) = attribute++-- | Create an element.+newElem :: MonadIO m => JSString -> m Elem+newElem = liftIO . jsCreateElem++-- | Create a text node.+newTextElem :: MonadIO m => JSString -> m Elem+newTextElem = liftIO . jsCreateTextNode++-- | Set a property of the given element.+setProp :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()+setProp e prop val = liftIO $ jsSet (elemOf e) prop val++-- | Set an attribute of the given element.+setAttr :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()+setAttr e prop val = liftIO $ jsSetAttr (elemOf e) prop val++-- | Get the value property of an element; a handy shortcut.+getValue :: (IsElem e, MonadIO m, JSType a) => e -> m (Maybe a)+getValue e = liftIO $ fromJSString `fmap` jsGet (elemOf e) "value"++-- | Get a property of an element.+getProp :: (IsElem e, MonadIO m) => e -> PropID -> m JSString+getProp e prop = liftIO $ jsGet (elemOf e) prop++-- | Get an attribute of an element.+getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m JSString+getAttr e prop = liftIO $ jsGetAttr (elemOf e) prop++-- | Get a CSS style property of an element.+getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m JSString+getStyle e prop = liftIO $ jsGetStyle (elemOf e) prop++-- | Set a CSS style property on an element.+setStyle :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m ()+setStyle e prop val = liftIO $ jsSetStyle (elemOf e) prop val++-- | Get an element by its HTML ID attribute.+elemById :: MonadIO m => ElemID -> m (Maybe Elem)+elemById eid = liftIO $ fromPtr `fmap` (jsFind eid)++-- | Get all elements of the given class.+elemsByClass :: MonadIO m => ElemClass -> m [Elem]+elemsByClass cls = liftIO $ fromPtr `fmap` (jsElemsByClassName cls)++-- | Get all children elements matching a query selector.+elemsByQS :: (IsElem e, MonadIO m) => e -> QuerySelector -> m [Elem]+elemsByQS el sel = liftIO $ fromPtr `fmap` (jsQuerySelectorAll (elemOf el) sel)++-- | Perform an IO action on an element.+withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a+withElem e act = do+  me' <- elemById e+  case me' of+    Just e' -> act e'+    _       -> error $ "No element with ID " ++ fromJSStr e ++ " found!"++-- | Perform an IO action over several elements. Throws an error if some of the+--   elements are not found.+withElems :: MonadIO m => [ElemID] -> ([Elem] -> m a) -> m a+withElems es act = do+    mes <- mapM elemById es+    if any isNothing mes+      then error $ "Elements with the following IDs could not be found: "+                 ++ show (findElems es mes)+      else act $ map fromJust mes+  where+    findElems (i:is) (Nothing:mes) = i : findElems is mes+    findElems (_:is) (_:mes)       = findElems is mes+    findElems _ _                  = []++-- | Perform an IO action over the a list of elements matching a query+--   selector.+withElemsQS :: (IsElem e, MonadIO m)+            => e+            -> QuerySelector+            -> ([Elem] -> m a)+            -> m a+withElemsQS el sel act = elemsByQS el sel >>= act++-- | Map an IO computation over the list of elements matching a query selector.+mapQS :: (IsElem e, MonadIO m) => e -> QuerySelector -> (Elem -> m a) -> m [a]+mapQS el sel act = elemsByQS el sel >>= mapM act++-- | Like @mapQS@ but returns no value.+mapQS_ :: (IsElem e, MonadIO m) => e -> QuerySelector -> (Elem -> m a) -> m ()+mapQS_ el sel act = elemsByQS el sel >>= mapM_ act++-- | Get a file from a file input element.+getFileData :: (IsElem e, MonadIO m) => e -> Int -> m (Maybe Blob)+getFileData e ix = liftIO $ do+    num <- getFiles (elemOf e)+    if ix < num+      then Just `fmap` getFile (elemOf e) ix+      else return Nothing++getFiles :: Elem -> IO Int+getFiles = ffi "(function(e){return e.files.length;})"++getFile :: Elem -> Int -> IO Blob+getFile = ffi "(function(e,ix){return e.files[ix];})"++-- | Get the name of the currently selected file from a file input element.+--   Any directory information is stripped, and only the actual file name is+--   returned, as the directory information is useless (and faked) anyway.+getFileName :: (IsElem e, MonadIO m) => e -> m JSString+getFileName e = liftIO $ do+    fn <- fromJSStr `fmap` getProp e "value"+    return $ toJSStr $ reverse $ takeWhile (not . separator) $ reverse fn+  where+    separator '/'  = True+    separator '\\' = True+    separator _    = False++-- | Add or remove a class from an element's class list.+setClass :: (IsElem e, MonadIO m) => e -> JSString -> Bool -> m ()+setClass e c x = liftIO $ setc (elemOf e) c x++setc :: Elem -> JSString -> Bool -> IO ()+setc = ffi "(function(e,c,x){x?e.classList.add(c):e.classList.remove(c);})"++-- | Toggle the existence of a class within an elements class list.+toggleClass :: (IsElem e, MonadIO m) => e -> JSString -> m ()+toggleClass e c = liftIO $ toggc (elemOf e) c++toggc :: Elem -> JSString -> IO ()+toggc = ffi "(function(e,c) {e.classList.toggle(c);})"++-- | Does the given element have a particular class?+hasClass :: (IsElem e, MonadIO m) => e -> JSString -> m Bool+hasClass e c = liftIO $ getc (elemOf e) c++getc :: Elem -> JSString -> IO Bool+getc = ffi "(function(e,c) {return e.classList.contains(c);})"

@@ -0,0 +1,11 @@+-- | Event handling for Haste.+module Haste.Events (+    module Core,+    module BasicEvents,+    module KeyEvents,+    module MouseEvents+  ) where+import Haste.Events.Core as Core+import Haste.Events.BasicEvents as BasicEvents+import Haste.Events.KeyEvents as KeyEvents+import Haste.Events.MouseEvents as MouseEvents

@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}+-- | Basic events: load, unload, focus, submit, etc.+module Haste.Events.BasicEvents (BasicEvent (..)) where+import Haste.Events.Core++data BasicEvent+  = Load+  | Unload+  | Change+  | Focus+  | Blur+  | Submit+  | Scroll++instance Event BasicEvent where+  type EventData BasicEvent = ()+  eventName Load   = "load"+  eventName Unload = "unload"+  eventName Change = "change"+  eventName Focus  = "focus"+  eventName Blur   = "blur"+  eventName Submit = "submit"+  eventName Scroll = "scroll"+  eventData _ _    = return ()

@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts #-}+-- | Basic framework for event handling.+module Haste.Events.Core (+    Event (..), MonadEvent (..),+    HandlerInfo,+    unregisterHandler, onEvent, preventDefault+  ) where+import Haste.Prim+import Haste.DOM.Core+import Haste.Foreign+import Control.Monad.IO.Class+import Data.IORef+import System.IO.Unsafe++-- | Any monad in which we're able to handle events.+class MonadIO m => MonadEvent m where+  mkHandler :: (a -> m ()) -> m (a -> IO ())++instance MonadEvent IO where+  mkHandler = return++-- | Any type that describes an event.+class Event evt where+  -- | The type of data to pass to handlers for this event.+  type EventData evt++  -- | The name of this event, as expected by the DOM.+  eventName :: evt -> JSString++  -- | Construct event data from the event identifier and the JS event object.+  eventData :: evt -> JSAny -> IO (EventData evt)++-- | Information about an event handler.+data HandlerInfo = HandlerInfo {+    -- | Name of the handler's event.+    handlerEvent :: JSString,+    -- | Element the handler is set on.+    handlerElem  :: Elem,+    -- | Handle to handler function.+    handlerFun   :: JSAny+  }++-- | Unregister an event handler.+unregisterHandler :: HandlerInfo -> IO ()+unregisterHandler (HandlerInfo ev el f) = unregEvt el ev f++-- | Reference to the event currently being handled.+{-# NOINLINE evtRef #-}+evtRef :: IORef (Maybe JSAny)+evtRef = unsafePerformIO $ newIORef Nothing++{-# INLINE setEvtRef #-}+setEvtRef :: JSAny -> IO ()+setEvtRef = writeIORef evtRef . Just++-- | Prevent the event being handled from resolving normally.+--   Does nothing if called outside an event handler.+preventDefault :: IO ()+preventDefault = readIORef evtRef >>= go+  where+    go :: Maybe JSAny -> IO ()+    go = ffi "(function(e){if(e){e.preventDefault();}})"++-- | Set an event handler on a DOM element.+onEvent :: (MonadEvent m, IsElem el, Event evt)+        => el            -- ^ Element to set handler on.+        -> evt           -- ^ Event to handle.+        -> (EventData evt -> m ()) -- ^ Event handler.+        -> m HandlerInfo -- ^ Information about the handler.+onEvent el evt f = do+  f' <- mkHandler $ \o -> prepareEvent o >>= f+  hdl <- liftIO $ setEvt e name f'+  return $ HandlerInfo {+      handlerEvent = name,+      handlerElem  = e,+      handlerFun   = hdl+    }+  where+    name = eventName evt+    e    = elemOf el+    prepareEvent o = liftIO $ do+      setEvtRef o+      eventData evt o++-- | Set an event handler on an element, returning a reference to the handler+--   exactly as seen by @addEventListener@. We can't reuse the reference to+--   the Haskell function as the FFI does some marshalling to functions,+--   meaning that the same function marshalled twice won't be reference equal+--   to each other.+setEvt :: Elem -> JSString -> (JSAny -> IO ()) -> IO JSAny+setEvt = ffi "(function(e,name,f){e.addEventListener(name,f,false);\+             \return [f];})"++-- | Unregister an event.+--   Note @f[0]@ and corresponding @[f]@ in 'setEvt'; this is a workaround for+--   a bug causing functions being packed into anything to be accidentally+--   called. Remove when properly fixed.+unregEvt :: Elem -> JSString -> JSAny -> IO ()+unregEvt = ffi "(function(e,name,f){e.removeEventListener(name,f[0]);})"

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-}+-- | Events relating to mouse keyboard input.+module Haste.Events.KeyEvents (KeyEvent (..), KeyData (..), mkKeyData) where+import Haste.Any+import Haste.Events.Core+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++-- | Event data for keyboard events.+data KeyData = KeyData {+    keyCode  :: !Int,+    keyCtrl  :: !Bool,+    keyAlt   :: !Bool,+    keyShift :: !Bool,+    keyMeta  :: !Bool+  } deriving (Show, Eq)++-- | Build a 'KeyData' object for the given key, without any modifier keys+--   pressed.+mkKeyData :: Int -> KeyData+mkKeyData n = KeyData {+    keyCode  = fromIntegral n,+    keyCtrl  = False,+    keyAlt   = False,+    keyShift = False,+    keyMeta  = False+  }++-- | Num instance for KeyData to enable pattern matching against numeric+--   key codes.+instance Num KeyData where+  fromInteger = mkKeyData . fromInteger+  a + b    = a {keyCode = keyCode a  +  keyCode b}+  a * b    = a {keyCode = keyCode a  *  keyCode b}+  a - b    = a {keyCode = keyCode a  -  keyCode b}+  negate a = a {keyCode = negate $ keyCode a}+  signum a = a {keyCode = signum $ keyCode a}+  abs a    = a {keyCode = abs $ keyCode a}++data KeyEvent+  = KeyPress+  | KeyUp+  | KeyDown++instance Event KeyEvent where+  type EventData KeyEvent = KeyData+  eventName KeyPress = "keypress"+  eventName KeyUp    = "keyup"+  eventName KeyDown  = "keydown"+  eventData _ e =+    KeyData <$> get e "keyCode"+            <*> get e "ctrlKey"+            <*> get e "altKey"+            <*> get e "shiftKey"+            <*> get e "metaKey"

@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, CPP #-}+-- | Events relating to mouse clicks and movement.+module Haste.Events.MouseEvents (+    MouseEvent (..), MouseData (..), MouseButton (..)+  ) where+import Haste.Events.Core+import Haste.Foreign+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++data MouseButton = MouseLeft | MouseMiddle | MouseRight+  deriving (Show, Eq, Enum)++instance FromAny MouseButton where+  fromAny = fmap toEnum . fromAny++-- | Event data for mouse events.+data MouseData = MouseData {+    -- | Mouse coordinates.+    mouseCoords      :: !(Int, Int),+    -- | Pressed mouse button, if any.+    mouseButton      :: !(Maybe MouseButton),+    -- | (x, y, z) mouse wheel delta. Always all zeroes except for 'Wheel'.+    mouseWheelDeltas :: !(Double, Double, Double)+  }++data MouseEvent+  = Click+  | DblClick+  | MouseDown+  | MouseUp+  | MouseMove+  | MouseOver+  | MouseOut+  | Wheel++instance Event MouseEvent where+  type EventData MouseEvent = MouseData+  eventName Click     = "click"+  eventName DblClick  = "dblclick"+  eventName MouseDown = "mousedown"+  eventName MouseUp   = "mouseup"+  eventName MouseMove = "mousemove"+  eventName MouseOver = "mouseover"+  eventName MouseOut  = "mouseout"+  eventName Wheel     = "wheel"+  eventData Wheel e =+    MouseData <$> jsGetMouseCoords e+              <*> pure Nothing+              <*> ((,,) <$> (get e "deltaX")+                        <*> (get e "deltaY")+                        <*> (get e "deltaZ"))++  eventData _ e =+    MouseData <$> jsGetMouseCoords e+              <*> get e "button"+              <*> pure (0,0,0)++jsGetMouseCoords :: JSAny -> IO (Int, Int)+jsGetMouseCoords = ffi "jsGetMouseCoords"

@@ -1,341 +1,159 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances,-             FlexibleInstances, TypeFamilies, OverlappingInstances, CPP,-             OverloadedStrings, UndecidableInstances #-}--- | Create functions on the fly from JS strings.---   Slower but more flexible alternative to the standard FFI.+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, BangPatterns, CPP #-}+{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif+-- | High level interface for interfacing with JavaScript. module Haste.Foreign (-    FFI, Pack (..), Unpack (..), Marshal,-    Unpacked, Opaque,-    ffi, export, toOpaque, fromOpaque+    module Haste.Any,+    FFI, JSFunc,+    ffi, constant, export   ) where import Haste.Prim-import Haste.JSType-import Data.Word-import Data.Int-import System.IO.Unsafe-import Unsafe.Coerce+import Haste.Any +-- | A JS function.+type JSFun = JSAny+ #ifdef __HASTE__-foreign import ccall eval :: JSString -> IO (Ptr a)-foreign import ccall "String" jsString :: Double -> JSString+foreign import ccall "eval" __eval :: JSString -> JSFun+foreign import ccall __apply :: JSFun -> Ptr [JSAny] -> IO JSAny+foreign import ccall __app0  :: JSFun -> IO JSAny+foreign import ccall __app1  :: JSFun -> JSAny -> IO JSAny+foreign import ccall __app2  :: JSFun -> JSAny -> JSAny -> IO JSAny+foreign import ccall __app3  :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny+foreign import ccall __app4  :: JSFun+                             -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny+foreign import ccall __app5  :: JSFun+                             -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny+                             -> IO JSAny+foreign import ccall __createJSFunc :: Int -> JSAny -> IO JSAny #else-eval :: JSString -> IO (Ptr a)-eval = error "Tried to use eval on server side!"-jsString :: Double -> JSString-jsString = error "Tried to use jsString on server side!"+__eval :: JSString -> JSFun+__eval _ = undefined+__apply :: JSFun -> Ptr [JSAny] -> IO JSAny+__apply _ _ = return undefined+__app0  :: JSFun -> IO JSAny+__app0 _ = return undefined+__app1  :: JSFun -> JSAny -> IO JSAny+__app1 _ _ = return undefined+__app2  :: JSFun -> JSAny -> JSAny -> IO JSAny+__app2 _ _ _ = return undefined+__app3  :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny+__app3 _ _ _ _ = return undefined+__app4  :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny+__app4 _ _ _ _ _ = return undefined+__app5  :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny+__app5 _ _ _ _ _ _ = return undefined+__createJSFunc :: Int -> JSAny -> IO JSAny+__createJSFunc _ = return undefined #endif --- | Opaque type representing a raw, unpacked JS value. The constructors have---   no meaning, but are only there to make sure GHC doesn't optimize the low---   level hackery in this module into oblivion.-data Unpacked = A | B---- | The Opaque type is inhabited by values that can be passed to Javascript---   using their raw Haskell representation. Opaque values are completely---   useless to Javascript code, and should not be inspected. This is useful---   for, for instance, storing data in some Javascript-native data structure---   for later retrieval.-newtype Opaque a = Opaque Unpacked--toOpaque :: a -> Opaque a-toOpaque = unsafeCoerce--fromOpaque :: Opaque a -> a-fromOpaque = unsafeCoerce--data Dummy = Dummy Unpacked--class Pack a where-  pack :: Unpacked -> a-  pack = unsafePack--class Unpack a where-  unpack :: a -> Unpacked-  unpack = unsafeUnpack---- | Class for marshallable types. Pack takes an opaque JS value and turns it---   into the type's proper Haste representation, and unpack is its inverse.---   The default instances make an effort to prevent wrongly typed values---   through, but you could probably break them with enough creativity.-class (Pack a, Unpack a) => Marshal a-instance (Pack a, Unpack a) => Marshal a--instance Pack Float-instance Pack Double-instance Pack JSAny-instance Pack JSString where-  pack = jsString . unsafePack-instance Pack Int where-  pack x = convert (unsafePack x :: Double)-instance Pack Int8 where-  pack x = convert (unsafePack x :: Double)-instance Pack Int16 where-  pack x = convert (unsafePack x :: Double)-instance Pack Int32 where-  pack x = convert (unsafePack x :: Double)-instance Pack Word where-  pack x = convert (unsafePack x :: Double)-instance Pack Word8 where-  pack x = convert (unsafePack x :: Double)-instance Pack Word16 where-  pack x = convert (unsafePack x :: Double)-instance Pack Word32 where-  pack x = convert (unsafePack x :: Double)-instance Pack () where-  pack _   = ()-instance Pack String where-  pack = fromJSStr . pack-instance Pack Unpacked where-  pack = id-instance Pack (Opaque a) where-  pack = Opaque-instance Pack Bool where-  pack x = if pack x > (0 :: Double) then True else False---- | Lists are marshalled into arrays.-instance Pack a => Pack [a] where-  pack arr = map pack . fromOpaque $ arr2lst arr 0---- | Maybe is simply a nullable type. Nothing is equivalent to null, and any---   non-null value is equivalent to x in Just x.-instance Pack a => Pack (Maybe a) where-  pack x = if isNull x then Nothing else Just (pack x)---- | Tuples are marshalled into arrays.-instance (Pack a, Pack b) => Pack (a, b) where-  pack x = case pack x of [a, b] -> (pack a, pack b)--instance (Pack a, Pack b, Pack c) => Pack (a, b, c) where-  pack x = case pack x of [a, b, c] -> (pack a, pack b, pack c)--instance (Pack a, Pack b, Pack c, Pack d) =>-         Pack (a, b, c, d) where-  pack x = case pack x of [a, b, c, d] -> (pack a, pack b, pack c, pack d)--instance (Pack a, Pack b, Pack c, Pack d, Pack e) =>-         Pack (a, b, c, d, e) where-  pack x = case pack x of [a,b,c,d,e] -> (pack a, pack b, pack c, pack d, pack e)--instance (Pack a, Pack b, Pack c, Pack d, Pack e,-          Pack f) => Pack (a, b, c, d, e, f) where-  pack x = case pack x of-    [a, b, c, d, e, f] -> (pack a, pack b, pack c, pack d, pack e, pack f)--instance (Pack a, Pack b, Pack c, Pack d, Pack e,-          Pack f, Pack g) => Pack (a, b, c, d, e, f, g) where-  pack x = case pack x of-    [a, b, c, d, e, f, g] -> (pack a,pack b,pack c,pack d,pack e,pack f,pack g)--instance (Pack a, Pack b, Pack c, Pack d, Pack e,-          Pack f, Pack g, Pack h) =>-         Pack (a, b, c, d, e, f, g, h) where-  pack x = case pack x of-    [a, b, c, d, e, f, g, h] -> (pack a, pack b, pack c, pack d, pack e,-                                 pack f, pack g, pack h)--instance (Pack a, Pack b, Pack c, Pack d, Pack e,-          Pack f, Pack g, Pack h, Pack i) =>-         Pack (a, b, c, d, e, f, g, h, i) where-  pack x = case pack x of-    [a, b, c, d, e, f, g, h, i] -> (pack a, pack b, pack c, pack d, pack e,-                                    pack f, pack g, pack h, pack i)--instance (Pack a, Pack b, Pack c, Pack d, Pack e,-          Pack f, Pack g, Pack h, Pack i, Pack j) =>-         Pack (a, b, c, d, e, f, g, h, i, j) where-  pack x = case pack x of-    [a, b, c, d, e, f, g, h, i, j] -> (pack a, pack b, pack c, pack d, pack e,-                                       pack f, pack g, pack h, pack i, pack j)--instance Unpack Float-instance Unpack Double-instance Unpack JSAny-instance Unpack JSString-instance Unpack Int-instance Unpack Int8-instance Unpack Int16-instance Unpack Int32-instance Unpack Word-instance Unpack Word8-instance Unpack Word16-instance Unpack Word32-instance Unpack () where-  unpack _ = unpack (0 :: Double)-instance Unpack String where-  unpack = unpack . toJSStr-instance Unpack Unpacked where-  unpack = id-instance Unpack (Opaque a) where-  unpack (Opaque x) = x-instance Unpack Bool where-  unpack True  = jsTrue-  unpack False = jsFalse---- | Lists are marshalled into arrays.-instance Unpack a => Unpack [a] where-  unpack = lst2arr . toOpaque . map unpack---- | Maybe is simply a nullable type. Nothing is equivalent to null, and any---   non-null value is equivalent to x in Just x.-instance Unpack a => Unpack (Maybe a) where-  unpack Nothing  = jsNull-  unpack (Just x) = unpack x---- | Tuples are marshalled into arrays.-instance (Unpack a, Unpack b) => Unpack (a, b) where-  unpack (a, b) = unpack [unpack a, unpack b]--instance (Unpack a, Unpack b, Unpack c) => Unpack (a, b, c) where-  unpack (a, b, c) = unpack [unpack a, unpack b, unpack c]--instance (Unpack a, Unpack b, Unpack c, Unpack d) =>-         Unpack (a, b, c, d) where-  unpack (a, b, c, d) = unpack [unpack a, unpack b, unpack c, unpack d]--instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e) =>-         Unpack (a, b, c, d, e) where-  unpack (a, b, c, d, e) = unpack [unpack a,unpack b,unpack c,unpack d,unpack e]--instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,-          Unpack f) => Unpack (a, b, c, d, e, f) where-  unpack (a, b, c, d, e, f) =-    unpack [unpack a, unpack b, unpack c, unpack d, unpack e, unpack f]--instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,-          Unpack f, Unpack g) => Unpack (a, b, c, d, e, f, g) where-  unpack (a, b, c, d, e, f, g) =-    unpack [unpack a,unpack b,unpack c,unpack d,unpack e,unpack f,unpack g]--instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,-          Unpack f, Unpack g, Unpack h) =>-         Unpack (a, b, c, d, e, f, g, h) where-  unpack (a, b, c, d, e, f, g, h) =-    unpack [unpack a, unpack b, unpack c, unpack d, unpack e,-            unpack f, unpack g, unpack h]--instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,-          Unpack f, Unpack g, Unpack h, Unpack i) =>-         Unpack (a, b, c, d, e, f, g, h, i) where-  unpack (a, b, c, d, e, f, g, h, i) =-    unpack [unpack a, unpack b, unpack c, unpack d, unpack e,-            unpack f, unpack g, unpack h, unpack i]--instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,-          Unpack f, Unpack g, Unpack h, Unpack i, Unpack j) =>-         Unpack (a, b, c, d, e, f, g, h, i, j) where-  unpack (a, b, c, d, e, f, g, h, i, j) =-    unpack [unpack a, unpack b, unpack c, unpack d, unpack e,-            unpack f, unpack g, unpack h, unpack i, unpack j]--{-# RULES "unpack array/Unpacked" forall x. unpack x = lst2arr (toOpaque x) #-}-{-# RULES "pack array/Unpacked" forall x. pack x = fromOpaque (arr2lst x 0) #-}--lst2arr :: Opaque [Unpacked] -> Unpacked-lst2arr = unsafePerformIO . ffi "lst2arr"--arr2lst :: Unpacked -> Int -> Opaque [Unpacked]-arr2lst arr ix = unsafePerformIO $ ffi "arr2lst" arr ix--jsNull, jsTrue, jsFalse :: Unpacked-jsTrue = unsafePerformIO $ ffi "true"-jsFalse = unsafePerformIO $ ffi "false"-jsNull = unsafePerformIO $ ffi "null"--isNull :: Unpacked -> Bool-isNull = unsafePerformIO . ffi "(function(x) {return x === null;})"-+-- | Any type that can be imported from JavaScript. This means any type which+--   has an instance of 'FromAny', and any function where all argument types+--   has 'ToAny' instances and the return type is in the IO monad and has a+--   'FromAny' instance. class FFI a where-  type T a-  unpackify :: T a -> a--instance Pack a => FFI (IO a) where-  type T (IO a) = IO Unpacked-  unpackify = fmap pack--instance (Unpack a, FFI b) => FFI (a -> b) where-  type T (a -> b) = Unpacked -> T b-  unpackify f x = unpackify (f $! unpack x)--class IOFun a where-  type X a-  packify :: a -> X a--instance Unpack a => IOFun (IO a) where-  type X (IO a) = Unpacked-  packify m = unsafePerformIO $ do-    x <- m-    return $! unpack x--instance (Pack a, IOFun b) => IOFun (a -> b) where-  type X (a -> b) = Unpacked -> X b-  packify f = \x -> packify (f $! pack x)--instance Unpack a => Unpack (IO a) where-  unpack = unsafePerformIO . unpackAct . toOpaque . fmap unpack-    where-      {-# NOINLINE unpackAct #-}-      unpackAct :: Opaque (IO Unpacked) -> IO Unpacked-      unpackAct =-        ffi (toJSStr $ "(function(m){" ++-             "    return (function() {" ++-             "        return (function(){return E(B(A(m,[0])));});" ++-             "      });" ++-             "})")+  __ffi :: JSFun -> [JSAny] -> a -instance (IOFun (a -> b)) => Unpack (a -> b) where-  unpack = unpackFun+instance FromAny a => FFI (IO a) where+  {-# INLINE __ffi #-}+  __ffi = ffiio -unpackFun :: IOFun a => a -> Unpacked-unpackFun =-    unsafePerformIO . go . toOpaque . packify-  where-    {-# NOINLINE go #-}-    go :: Opaque a -> IO Unpacked-    go = ffi (toJSStr $ "(function(f) {" ++-              "  return (function() {" ++-              "      return (function(){" ++-              "        var args=Array.prototype.slice.call(arguments,0);"++-              "        args.push(0);" ++-              "        return E(B(A(f, args)));" ++-              "    });" ++-              "  });" ++-              "})")+instance (ToAny a, FFI b) => FFI (a -> b) where+  {-# INLINE __ffi #-}+  __ffi f !as !a = __ffi f (a' : as)+    where !a' = toAny a +{-# INLINE [0] ffiio #-}+-- | Apply the result of an FFI call.+ffiio :: FromAny a => JSFun -> [JSAny] -> IO a+ffiio !f !as = __apply f (toPtr as) >>= fromAny --- | Creates a function based on the given string of Javascript code. If this---   code is not well typed or is otherwise incorrect, your program may crash---   or misbehave in mystifying ways. Haste makes a best-effort try to save you---   from poorly typed JS here, but there are no guarantees.+{-# INLINE ffi #-}+-- | Creates a Haskell function from the given string of JavaScript code. If+--   this code is not well typed or is otherwise incorrect, your program may+--   crash or misbehave in mystifying ways. Haste makes a best-effort try to+--   save you from poorly typed JS here, but there are no guarantees. -- --   For instance, the following WILL cause crazy behavior due to wrong types:---   ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int+--   @ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int@ -----   In other words, this function is completely unsafe - use with caution.+--   In other words, this function is as unsafe as the JS it calls on. You+--   have been warned. -----   ALWAYS use type signatures for functions defined using this function, as---   the argument marshalling is decided by the type signature.+--   The imported JS is evaluated lazily, unless (a) it is a function object+--   in which case evaluation order does not affect the semantics of the+--   imported code, or if (b) the imported code is explicitly marked as strict:+--+--       someFunction = ffi "__strict(someJSFunction)"+--+--   Literals which depends on some third party initialization, the existence+--   of a DOM tree or some other condition which is not fulfilled at load time+--   should *not* be marked strict. ffi :: FFI a => JSString -> a-ffi = unpackify . unsafeEval+ffi s = __ffi f []+  where+    {-# NOINLINE f #-}+    f = __eval s --- | Export a symbol. That symbol may then be accessed from Javascript through+-- | Create a Haskell value from a constant JS expression.+constant :: FromAny a => JSString -> a+constant = veryUnsafePerformIO . fromAny . __eval++-- Don't build intermediate list for functions of <= 5 arguments.+{-# RULES+"app0" [1] forall f. ffiio f [] = __app0 f >>= fromAny+"app1" [1] forall f a. ffiio f [a] = __app1 f a >>= fromAny+"app2" [1] forall f a b. ffiio f [b,a] = __app2 f a b >>= fromAny+"app3" [1] forall f a b c. ffiio f [c,b,a] = __app3 f a b c >>= fromAny+"app4" [1] forall f a b c d. ffiio f [d,c,b,a] = __app4 f a b c d >>= fromAny+"app5" [1] forall f a b c d e. ffiio f [e,d,c,b,a] =+                                 __app5 f a b c d e >>= fromAny+  #-}++-- | Export a symbol. That symbol may then be accessed from JavaScript through --   Haste.name() as a normal function. Remember, however, that if you are --   using --with-js to include your JS, in conjunction with---   --opt-google-closure or any option that implies it, you will instead need+--   --opt-minify or any option that implies it, you will instead need --   to access your exports through Haste[\'name\'](), or Closure will mangle --   your function names.-{-# NOINLINE export #-}-export :: Unpack a => JSString -> a -> IO ()+{-# INLINE export #-}+export :: ToAny a => JSString -> a -> IO () export = ffi "(function(s,f){Haste[s] = f;})" -unsafeUnpack :: a -> Unpacked-unsafeUnpack x =-  case unsafeCoerce x of-    Dummy x' -> x'+type family JS a where+  JS (a -> b) = JSAny -> JS b+  JS (IO a)   = IO JSAny+  JS a        = JSAny -unsafePack :: Unpacked -> a-unsafePack = unsafeCoerce . Dummy+class JSFunc a where+  mkJSFunc :: a -> JS a+  arity    :: a -> Int -unsafeEval :: JSString -> a-unsafeEval s = unsafePerformIO $ do-  x <- eval s-  return $ fromPtr x+instance (ToAny a, JS a ~ JSAny) => JSFunc a where+  mkJSFunc = toAny+  arity _  = 0++instance ToAny a => JSFunc (IO a) where+  mkJSFunc = fmap toAny+  arity _  = 1++instance (FromAny a, JSFunc b) => JSFunc (a -> b) where+  mkJSFunc f = mkJSFunc . f . veryUnsafePerformIO . fromAny+  arity f    = 1 + arity (f undefined)++instance (FromAny a, JSFunc b) => ToAny (a -> b) where+  toAny f =+    veryUnsafePerformIO . __createJSFunc (arity f) . toAny . toOpaque $ mkJSFunc f++instance ToAny a => ToAny (IO a) where+  toAny = veryUnsafePerformIO . __createJSFunc 0 . toAny . toOpaque . mkJSFunc++#if __GLASGOW_HASKELL__ < 710+instance FFI a => FromAny a where+#else+instance {-# OVERLAPPABLE #-} FFI a => FromAny a where+#endif+  fromAny f = return $ __ffi f []

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}+-- | Request and cancel animation frames from the browser.+--   Straightforward bindings to the corresponding DOM interface.+module Haste.Graphics.AnimationFrame (+    FrameRequest, HRTimeStamp,+    requestAnimationFrame,+    cancelAnimationFrame+  ) where+import Haste.Foreign+import Haste.Performance++-- | Handle to a previously issued request for an animation frame.+--   Only useful together with 'cancelAnimationFrame'.+newtype FrameRequest = FrameRequest JSAny deriving (ToAny, FromAny)++-- | Request a function to be called by the browser before the next repaint.+--   Paints generally happen in tune with the user's monitor refresh rate,+--   which usually means at 60 FPS.+--+--   Do note that you need to request *each* animation callback you plan to+--   use, similar to @setTimeout@ as opposed to @setInterval@, as they are not+--   recurring.+requestAnimationFrame :: (HRTimeStamp -> IO ()) -> IO FrameRequest+requestAnimationFrame = ffi "window.requestAnimationFrame"++-- | Cancel an animation callback previously requested by+--   'requestAnimationFrame'.+cancelAnimationFrame :: FrameRequest -> IO ()+cancelAnimationFrame = ffi "window.cancelAnimationFrame"

@@ -10,9 +10,7 @@   -- Classes   ImageBuffer (..), BitmapSource (..),   -- Obtaining a canvas for drawing-  getCanvasById, getCanvas, createCanvas, canvasElem,-  -- Working with bitmaps-  bitmapElem,+  getCanvasById, getCanvas, createCanvas,   -- Rendering pictures, extracting data from a canvas   render, renderOnTop, buffer, toDataURL,   -- Working with colors and opacity@@ -28,12 +26,18 @@   -- Extending the library   withContext   ) where+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Monad.IO.Class-import System.IO.Unsafe+import Data.Maybe (fromJust) import Haste+import qualified Haste.DOM.JSString as J import Haste.Concurrent (CIO) -- for SPECIALISE pragma-import Haste.Foreign (Pack (..), Unpack (..))+import Haste.Foreign (ToAny (..), FromAny (..))+#ifdef __HASTE__+import Haste.Prim (JSString (..), JSAny (..))+#endif  #ifdef __HASTE__ foreign import ccall jsHasCtx2D :: Elem -> IO Bool@@ -108,7 +112,7 @@ -- | A bitmap, backed by an IMG element. --   JS representation is a reference to the backing IMG element. newtype Bitmap = Bitmap Elem-  deriving (Pack, Unpack)+  deriving (ToAny, FromAny)  -- | Any type that contains a buffered image which can be drawn onto a canvas. class ImageBuffer a where@@ -135,8 +139,8 @@  instance BitmapSource URL where   loadBitmap url = liftIO $ do-    img <- newElem "img"-    setProp' img "src" (toJSString url)+    img <- J.newElem "img"+    J.setProp img "src" (toJSString url)     loadBitmap img  instance BitmapSource Elem where@@ -149,13 +153,11 @@   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+instance IsElem Canvas where+  elemOf (Canvas _ctx e) = e --- | Get the HTML element associated with the given bitmap.-bitmapElem :: Bitmap -> Elem-bitmapElem (Bitmap e) = e+instance IsElem Bitmap where+  elemOf (Bitmap e) = e  -- | A point in the plane. type Point = (Double, Double)@@ -190,7 +192,7 @@ -- | A drawing context; part of a canvas. --   JS representation is the drawing context object itself. newtype Ctx = Ctx JSAny-  deriving (Pack, Unpack)+  deriving (ToAny, FromAny)  -- | A canvas; a viewport into which a picture can be rendered. --   The origin of the coordinate system used by the canvas is the top left@@ -198,14 +200,15 @@ --   JS representation is a reference to the backing canvas element. data Canvas = Canvas !Ctx !Elem -instance Pack Canvas where-  pack c =-    case unsafePerformIO . getCanvas $ pack c of-      Just c' -> c'-      _       -> error "Attempted to pack a non-canvas element into a Canvas!"+instance FromAny Canvas where+  fromAny c = do+    mcan <- fromAny c >>= getCanvas+    case mcan of+      Just can -> return can+      _        -> error "Attempted to turn a non-canvas element into a Canvas!" -instance Unpack Canvas where-  unpack (Canvas _ el) = unpack el+instance ToAny Canvas where+  toAny (Canvas _ el) = toAny el  -- | A picture that can be drawn onto a canvas. newtype Picture a = Picture {unP :: Ctx -> IO a}@@ -214,16 +217,16 @@ newtype Shape a = Shape {unS :: Ctx -> IO a}  instance Functor Picture where-	fmap f p = Picture $ \ctx ->-		unP p ctx >>= return . f+  fmap f p = Picture $ \ctx ->+    unP p ctx >>= return . f  instance Applicative Picture where-	pure a = Picture $ \_ -> return a+  pure a = Picture $ \_ -> return a -	pfab <*> pa = Picture $ \ctx -> do-		fab <- unP pfab ctx-		a   <- unP pa   ctx-		return (fab a)+  pfab <*> pa = Picture $ \ctx -> do+    fab <- unP pfab ctx+    a   <- unP pa   ctx+    return (fab a)  instance Monad Picture where   return x = Picture $ \_ -> return x@@ -232,16 +235,16 @@     unP (f x) ctx  instance Functor Shape where-	fmap f s = Shape $ \ctx ->-		unS s ctx >>= return . f+  fmap f s = Shape $ \ctx ->+    unS s ctx >>= return . f  instance Applicative Shape where-	pure a = Shape $ \_ -> return a+  pure a = Shape $ \_ -> return a -	sfab <*> sa = Shape $ \ctx -> do-		fab <- unS sfab ctx-		a   <- unS sa   ctx-		return (fab a)+  sfab <*> sa = Shape $ \ctx -> do+    fab <- unS sfab ctx+    a   <- unS sa   ctx+    return (fab a)  instance Monad Shape where   return x = Shape $ \_ -> return x@@ -250,9 +253,9 @@     unS (f x) ctx  -- | Create a 2D drawing context from a DOM element identified by its ID.-getCanvasById :: MonadIO m => ElemID -> m (Maybe Canvas)+getCanvasById :: MonadIO m => String -> m (Maybe Canvas) getCanvasById eid = liftIO $ do-  e <- elemById eid+  e <- J.elemById (toJSString eid)   maybe (return Nothing) getCanvas e  -- | Create a 2D drawing context from a DOM element.@@ -266,12 +269,12 @@     _    -> return Nothing  -- | Create an off-screen buffer of the specified size.-createCanvas :: Int -> Int -> IO (Maybe Canvas)+createCanvas :: Int -> Int -> IO Canvas createCanvas w h = do-  buf <- newElem "canvas"-  setProp' buf "width" (toJSString w)-  setProp' buf "height" (toJSString h)-  getCanvas buf+  buf <- J.newElem "canvas"+  J.setProp buf "width" (toJSString w)+  J.setProp buf "height" (toJSString h)+  fromJust <$> getCanvas buf  -- | Clear a canvas, then draw a picture onto it. {-# SPECIALISE render :: Canvas -> Picture a -> IO a #-}@@ -295,13 +298,9 @@ -- | Create a new off-screen buffer and store the given picture in it. buffer :: MonadIO m => Int -> Int -> Picture () -> m Bitmap buffer w h pict = liftIO $ do-  mbuf <- createCanvas w h-  case mbuf of-    Just buf@(Canvas _ el) -> do-      render buf pict-      return $ Bitmap el-    _ -> do-      Bitmap <$> newElem "img"+  buf@(Canvas _ el) <- createCanvas w h+  render buf pict+  return $ Bitmap el  -- | Perform a computation over the drawing context of the picture. --   This is handy for operations which are either impossible, hard or@@ -312,42 +311,42 @@ -- | Set a new color for strokes. setStrokeColor :: Color -> Picture () setStrokeColor c = Picture $ \(Ctx ctx) -> do-  setProp' (Elem ctx) "strokeStyle" (color2JSString c)+  J.setProp (Elem ctx) "strokeStyle" (color2JSString c)  -- | Set a new fill color. setFillColor :: Color -> Picture () setFillColor c = Picture $ \(Ctx ctx) -> do-  setProp' (Elem ctx) "fillStyle" (color2JSString c)+  J.setProp (Elem ctx) "fillStyle" (color2JSString c)  -- | Draw a picture with the given opacity. opacity :: Double -> Picture () -> Picture () opacity alpha (Picture pict) = Picture $ \(Ctx ctx) -> do-  alpha' <- getProp' (Elem ctx) "globalAlpha"-  setProp' (Elem ctx) "globalAlpha" (toJSString alpha)+  alpha' <- J.getProp (Elem ctx) "globalAlpha"+  J.setProp (Elem ctx) "globalAlpha" (toJSString alpha)   pict (Ctx ctx)-  setProp' (Elem ctx) "globalAlpha" alpha'+  J.setProp (Elem ctx) "globalAlpha" alpha'  -- | Draw the given Picture using the specified Color for both stroke and fill, --   then restore the previous stroke and fill colors. color :: Color -> Picture () -> Picture () color c (Picture pict) = Picture $ \(Ctx ctx) -> do-    fc <- getProp' (Elem ctx) "fillStyle"-    sc <- getProp' (Elem ctx) "strokeStyle"-    setProp' (Elem ctx) "fillStyle" c'-    setProp' (Elem ctx) "strokeStyle" c'+    fc <- J.getProp (Elem ctx) "fillStyle"+    sc <- J.getProp (Elem ctx) "strokeStyle"+    J.setProp (Elem ctx) "fillStyle" c'+    J.setProp (Elem ctx) "strokeStyle" c'     pict (Ctx ctx)-    setProp' (Elem ctx) "fillStyle" fc-    setProp' (Elem ctx) "strokeStyle" sc+    J.setProp (Elem ctx) "fillStyle" fc+    J.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)+  lw <- J.getProp (Elem ctx) "lineWidth"+  J.setProp (Elem ctx) "lineWidth" (toJSString w)   pict (Ctx ctx)-  setProp' (Elem ctx) "lineWidth" lw+  J.setProp (Elem ctx) "lineWidth" lw  -- | Draw the specified picture using the given point as the origin. translate :: Vector -> Picture () -> Picture ()@@ -434,10 +433,10 @@ -- | Draw a picture using a certain font. Obviously only affects text. font :: String -> Picture () -> Picture () font f (Picture pict) = Picture $ \(Ctx ctx) -> do-  f' <- getProp' (Elem ctx) "font"-  setProp' (Elem ctx) "font" (toJSString f)+  f' <- J.getProp (Elem ctx) "font"+  J.setProp (Elem ctx) "font" (toJSString f)   pict (Ctx ctx)-  setProp' (Elem ctx) "font" f'+  J.setProp (Elem ctx) "font" f'  -- | Draw some text onto the canvas. text :: Point -> String -> Picture ()

@@ -5,38 +5,28 @@   ) where import Haste.Foreign import Control.Monad.IO.Class-import Haste.Callback import Haste.Prim-import Unsafe.Coerce -newtype HashCallback = HashCallback (JSString -> JSString -> IO ())--instance Pack HashCallback where-  pack = unsafeCoerce-instance Unpack HashCallback where-  unpack = unsafeCoerce- -- | Register a callback to be run whenever the URL hash changes. --   The two arguments of the callback are the new and old hash respectively.-onHashChange :: (MonadIO m, GenericCallback (m ()) m, CB (m ()) ~ IO ())-              => (String -> String -> m ())-              -> m ()+onHashChange :: MonadIO m+             => (String -> String -> IO ())+             -> m () onHashChange f = do     firsthash <- getHash'-    f' <- toCallback $ \old new -> f (fromJSStr old) (fromJSStr new)-    liftIO $ jsOnHashChange firsthash (HashCallback f')+    liftIO $ jsOnHashChange firsthash cb+  where+    cb = \old new -> f (fromJSStr old) (fromJSStr new)  -- | JSString version of @onHashChange@.-onHashChange' :: (MonadIO m, GenericCallback (m ()) m, CB (m ()) ~ IO ())-              => (JSString -> JSString -> m ())+onHashChange' :: MonadIO m+              => (JSString -> JSString -> IO ())               -> m () onHashChange' f = do     firsthash <- getHash'-    f' <- toCallback f-    liftIO $ jsOnHashChange firsthash (HashCallback f')+    liftIO $ jsOnHashChange firsthash f -{-# NOINLINE jsOnHashChange #-}-jsOnHashChange :: JSString -> HashCallback -> IO ()+jsOnHashChange :: JSString -> (JSString -> JSString -> IO ()) -> IO () jsOnHashChange =   ffi "(function(firsthash,cb){\           \window.__old_hash = firsthash;\@@ -44,7 +34,7 @@             \var oldhash = window.__old_hash;\             \var newhash = window.location.hash.split('#')[1] || '';\             \window.__old_hash = newhash;\-            \B(A(cb, [[0,oldhash],[0,newhash],0]));\+            \cb(oldhash,newhash);\           \};\        \})" @@ -56,7 +46,6 @@ setHash' :: MonadIO m => JSString -> m () setHash' = liftIO . jsSetHash -{-# NOINLINE jsSetHash #-} jsSetHash :: JSString -> IO () jsSetHash = ffi "(function(h) {location.hash = '#'+h;})" @@ -68,6 +57,5 @@ getHash' :: MonadIO m => m JSString getHash' = liftIO jsGetHash -{-# NOINLINE jsGetHash #-} jsGetHash :: IO JSString jsGetHash = ffi "(function() {return location.hash.substring(1);})"

@@ -9,14 +9,18 @@ --   browser that supports JSON.parse; IE does this from version 8 and up, and --   everyone else has done it since just about forever. module Haste.JSON (JSON (..), encodeJSON, decodeJSON, toObject, (!), (~>)) where+import Prelude hiding (null) import Haste import Haste.Prim import Data.String as S #ifndef __HASTE__+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative-import Data.Char (ord)+#endif import Haste.Parsing-import Numeric (showHex)+#else+import System.IO.Unsafe+import Haste.Foreign hiding (toObject) #endif  -- | Create a Javascript object from a JSON object. Only makes sense in a@@ -24,7 +28,12 @@ toObject :: JSON -> JSAny #ifdef __HASTE__ toObject = jsJSONParse . encodeJSON-foreign import ccall jsJSONParse :: JSString -> JSAny+jsJSONParse :: JSString -> JSAny+jsJSONParse = unsafePerformIO . go+  where+    {-# NOINLINE go #-}+    go :: JSString -> IO JSAny+    go = ffi "(function(s){return JSON.parse(s);})" #else toObject j = error $ "Call to toObject in non-browser: " ++ show j #endif@@ -33,8 +42,8 @@ -- Remember to update jsParseJSON if this data type changes! data JSON   = Num  {-# UNPACK #-} !Double-  | Str  {-# UNPACK #-} !JSString-  | Bool {-# UNPACK #-} !Bool+  | Str  !JSString+  | Bool !Bool   | Arr  ![JSON]   | Dict ![(JSString, JSON)]   | Null@@ -42,6 +51,13 @@ instance IsString JSON where   fromString = Str . S.fromString +instance JSType JSON where+  toJSString = encodeJSON+  fromJSString x =+    case decodeJSON x of+      Right x' -> Just x'+      _        -> Nothing+ numFail :: a numFail = error "Num JSON: not a numeric JSON node!" @@ -78,8 +94,6 @@       | c == '\\'          = "\\\\" ++ unq cs       | otherwise          = c : unq cs     unq _          = ['"']--    unicodeChar c str = c : str #endif  -- | Look up a JSON object from a JSON dictionary. Panics if the dictionary@@ -158,26 +172,26 @@     boolean = oneOf [string "true" >> pure True, string "false" >> pure False]     null = string "null" >> pure Null     array = do-      char '[' >> possibly whitespace+      _ <- char '[' >> possibly whitespace       elements <- commaSeparated json-      possibly whitespace >> char ']'+      _ <- possibly whitespace >> char ']'       return elements     commaSeparated p =       oneOf [do x <- p-                possibly whitespace >> char ',' >> possibly whitespace+                _ <- possibly whitespace >> char ',' >> possibly whitespace                 xs <- commaSeparated p                 return (x:xs),              do x <- p                 return [x],              do return []]     object = do-      char '{' >> possibly whitespace+      _ <- char '{' >> possibly whitespace       pairs <- commaSeparated kvPair-      possibly whitespace >> char '}'+      _ <- possibly whitespace >> char '}'       return pairs     kvPair = do       k <- jsstring-      possibly whitespace >> char ':' >> possibly whitespace+      _ <- possibly whitespace >> char ':' >> possibly whitespace       v <- json       return (k, v) #endif

@@ -0,0 +1,318 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface, CPP, MagicHash #-}+-- | JSString standard functions, to make them a more viable alternative to+--   the horribly inefficient standard Strings.+--+--   Many functions have linear time complexity due to JavaScript engines not+--   implementing slicing, etc. in constant time.+--+--   All functions are supported on both client and server, with the exception+--   of 'match', 'matches', 'regex' and 'replace', which are wrappers on top of+--   JavaScript's native regular expressions and thus only supported on the+--   client.+module Haste.JSString (+    -- | Building JSStrings+    empty, singleton, pack, cons, snoc, append, replicate,+    -- | Deconstructing JSStrings+    unpack, head, last, tail, drop, take, init, splitAt,+    -- | Examining JSStrings+    null, length, any, all,+    -- | Modifying JSStrings+    map, reverse, intercalate, foldl', foldr, concat, concatMap,+    -- | Regular expressions (client-side only)+    RegEx, match, matches, regex, replace+  ) where+import qualified Data.List+import Prelude hiding (foldr, concat, concatMap, reverse, map, all, any,+                       length, null, splitAt, init, take, drop, tail, head,+                       last, replicate)+import Data.String+import Haste.Prim+import Haste.Foreign++#ifdef __HASTE__+import GHC.Prim+import System.IO.Unsafe++{-# INLINE d2c #-}+d2c :: Double -> Char+d2c d = unsafeCoerce# d++foreign import ccall _jss_singleton :: Char -> JSString+foreign import ccall _jss_cons :: Char -> JSString -> JSString+foreign import ccall _jss_snoc :: JSString -> Char -> JSString+foreign import ccall _jss_append :: JSString -> JSString -> JSString+foreign import ccall _jss_len :: JSString -> Int+foreign import ccall _jss_index :: JSString -> Int -> Double+foreign import ccall _jss_substr :: JSString -> Int -> JSString+foreign import ccall _jss_take :: Int -> JSString -> JSString+foreign import ccall _jss_rev :: JSString -> JSString+foreign import ccall _jss_re_match :: JSString -> RegEx -> Bool+foreign import ccall _jss_re_compile :: JSString -> JSString -> RegEx+foreign import ccall _jss_re_replace :: JSString -> RegEx -> JSString -> JSString+foreign import ccall _jss_re_find :: RegEx -> JSString -> Ptr [JSString]++{-# INLINE _jss_map #-}+_jss_map :: (Char -> Char) -> JSString -> JSString+_jss_map f = _jss_cmap (_jss_singleton . f)++{-# INLINE _jss_cmap #-}+_jss_cmap :: (Char -> JSString) -> JSString -> JSString+_jss_cmap f s = unsafePerformIO $ cmap_js (return . f) s++cmap_js :: (Char -> IO JSString) -> JSString -> IO JSString+cmap_js = ffi "(function(f,s){\+var s2 = '';\+for(var i in s) {\+   s2 += f(s.charCodeAt(i));\+}\+return s2;})"++{-# INLINE _jss_foldl #-}+_jss_foldl :: (ToAny a, FromAny a) => (a -> Char -> a) -> a -> JSString -> a+_jss_foldl f x s = fromOpaque . unsafePerformIO $ do+  foldl_js (\a c ->  toOpaque $ f (fromOpaque a) c) (toOpaque x) s++foldl_js :: (Opaque a -> Char -> Opaque a)+         -> Opaque a+         -> JSString+         -> IO (Opaque a)+foldl_js = ffi "(function(f,x,s){\+for(var i in s) {\+  x = f(x,s.charCodeAt(i));\+}\+return x;})"++{-# INLINE _jss_foldr #-}+_jss_foldr :: (ToAny a, FromAny a) => (Char -> a -> a) -> a -> JSString -> a+_jss_foldr f x s = fromOpaque . unsafePerformIO $ do+  foldr_js (\c -> toOpaque . f c . fromOpaque) (toOpaque x) s++foldr_js :: (Char -> Opaque a -> Opaque a)+         -> Opaque a+         -> JSString+         -> IO (Opaque a)+foldr_js = ffi "(function(f,x,s){\+for(var i = s.length-1; i >= 0; --i) {\+  x = f(s.charCodeAt(i),x);\+}\+return x;})"++#else++{-# INLINE d2c #-}+d2c :: Char -> Char+d2c = id++_jss_singleton :: Char -> JSString+_jss_singleton c = toJSStr [c]++_jss_cons :: Char -> JSString -> JSString+_jss_cons c s = toJSStr (c : fromJSStr s)++_jss_snoc :: JSString -> Char -> JSString+_jss_snoc s c = toJSStr (fromJSStr s ++ [c])++_jss_append :: JSString -> JSString -> JSString+_jss_append a b = catJSStr "" [a, b]++_jss_len :: JSString -> Int+_jss_len s = Data.List.length $ fromJSStr s++_jss_index :: JSString -> Int -> Char+_jss_index s n = fromJSStr s !! n++_jss_substr :: JSString -> Int -> JSString+_jss_substr s n = toJSStr $ Data.List.drop n $ fromJSStr s++_jss_take :: Int -> JSString -> JSString+_jss_take n = toJSStr . Data.List.take n . fromJSStr++_jss_map :: (Char -> Char) -> JSString -> JSString+_jss_map f = toJSStr . Data.List.map f . fromJSStr++_jss_cmap :: (Char -> JSString) -> JSString -> JSString+_jss_cmap f =+  toJSStr . Data.List.concat . Data.List.map (fromJSStr . f) . fromJSStr++_jss_rev :: JSString -> JSString+_jss_rev = toJSStr . Data.List.reverse . fromJSStr++_jss_foldl :: (a -> Char -> a) -> a -> JSString -> a+_jss_foldl f x = Data.List.foldl' f x . fromJSStr++_jss_foldr :: (Char -> a -> a) -> a -> JSString -> a+_jss_foldr f x = Data.List.foldr f x . fromJSStr++_jss_re_compile :: JSString -> JSString -> RegEx+_jss_re_compile _ _ =+  error "Regular expressions are only supported client-side!"++_jss_re_match :: JSString -> RegEx -> Bool+_jss_re_match _ _ =+  error "Regular expressions are only supported client-side!"++_jss_re_replace :: JSString -> RegEx -> JSString -> JSString+_jss_re_replace _ _ _ =+  error "Regular expressions are only supported client-side!"++_jss_re_find :: RegEx -> JSString -> Ptr [JSString]+_jss_re_find _ _ =+  error "Regular expressions are only supported client-side!"++#endif++-- | A regular expression. May be used to match and replace JSStrings.+newtype RegEx = RegEx JSAny++instance IsString RegEx where+  fromString s = _jss_re_compile (fromString s) ""++-- | O(1) The empty JSString.+empty :: JSString+empty = ""++-- | O(1) JSString consisting of a single character.+singleton :: Char -> JSString+singleton = _jss_singleton++-- | O(n) Convert a list of Char into a JSString.+pack :: [Char] -> JSString+pack = toJSStr++-- | O(n) Convert a JSString to a list of Char.+unpack :: JSString -> [Char]+unpack = fromJSStr++infixr 5 `cons`+-- | O(n) Prepend a character to a JSString.+cons :: Char -> JSString -> JSString+cons = _jss_cons++infixl 5 `snoc`+-- | O(n) Append a character to a JSString.+snoc :: JSString -> Char -> JSString+snoc = _jss_snoc++-- | O(n) Append two JSStrings.+append :: JSString -> JSString -> JSString+append = _jss_append++-- | O(1) Extract the first element of a non-empty JSString.+head :: JSString -> Char+head s =+#ifdef __HASTE__+  case _jss_index s 0 of+    c | isNaN c   -> error "Haste.JSString.head: empty JSString"+      | otherwise -> d2c c -- Double/Int/Char share representation.+#else+  Data.List.head $ fromJSStr s+#endif++-- | O(1) Extract the last element of a non-empty JSString.+last :: JSString -> Char+last s =+  case _jss_len s of+    0 -> error "Haste.JSString.head: empty JSString"+    n -> d2c (_jss_index s (n-1))++-- | O(n) All elements but the first of a JSString. Returns an empty JSString+--   if the given JSString is empty.+tail :: JSString -> JSString+tail s = _jss_substr s 1++-- | O(n) Drop 'n' elements from the given JSString.+drop :: Int -> JSString -> JSString+drop n s = _jss_substr s (max 0 n)++-- | O(n) Take 'n' elements from the given JSString.+take :: Int -> JSString -> JSString+take n s = _jss_take n s++-- | O(n) All elements but the last of a JSString. Returns an empty JSString+--   if the given JSString is empty.+init :: JSString -> JSString+init s = _jss_take (_jss_len s-1) s++-- | O(1) Test whether a JSString is empty.+null :: JSString -> Bool+null s = _jss_len s == 0++-- | O(1) Get the length of a JSString as an Int.+length :: JSString -> Int+length s = _jss_len s++-- | O(n) Map a function over the given JSString.+map :: (Char -> Char) -> JSString -> JSString+map = _jss_map++-- | O(n) reverse a JSString.+reverse :: JSString -> JSString+reverse = _jss_rev++-- | O(n) Join a list of JSStrings, with a specified separator. Equivalent to+--   'String.join'.+intercalate :: JSString -> [JSString] -> JSString+intercalate = catJSStr++-- | O(n) Left fold over a JSString.+foldl' :: (ToAny a, FromAny a) => (a -> Char -> a) -> a -> JSString -> a+foldl' = _jss_foldl++-- | O(n) Right fold over a JSString.+foldr :: (ToAny a, FromAny a) => (Char -> a -> a) -> a -> JSString -> a+foldr = _jss_foldr++-- | O(n) Concatenate a list of JSStrings.+concat :: [JSString] -> JSString+concat = catJSStr ""++-- | O(n) Map a function over a JSString, then concatenate the results.+--   Note that this function is actually faster than 'map' in most cases.+concatMap :: (Char -> JSString) -> JSString -> JSString+concatMap = _jss_cmap++-- | O(n) Determines whether any character in the string satisfies the given+--   predicate.+any :: (Char -> Bool) -> JSString -> Bool+any p = Haste.JSString.foldl' (\a x -> a || p x) False++-- | O(n) Determines whether all characters in the string satisfy the given+--   predicate.+all :: (Char -> Bool) -> JSString -> Bool+all p = Haste.JSString.foldl' (\a x -> a && p x) False++-- | O(n) Create a JSString containing 'n' instances of a single character.+replicate :: Int -> Char -> JSString+replicate n c = Haste.JSString.pack $ Data.List.replicate n c++-- | O(n) Equivalent to (take n xs, drop n xs).+splitAt :: Int -> JSString -> (JSString, JSString)+splitAt n s = (Haste.JSString.take n s, Haste.JSString.drop n s)++-- | O(n) Determines whether the given JSString matches the given regular+--   expression or not.+matches :: JSString -> RegEx -> Bool+matches = _jss_re_match++-- | O(n) Find all strings corresponding to the given regular expression.+match :: RegEx -> JSString -> [JSString]+match re s = fromPtr $ _jss_re_find re s++-- | O(n) Compile a regular expression and an (optionally empty) list of flags+--   into a 'RegEx' which can be used to match, replace, etc. on JSStrings.+--+--   The regular expression and flags are passed verbatim to the browser's+--   RegEx constructor, meaning that the syntax is the same as when using+--   regular expressions in raw JavaScript.+regex :: JSString -- ^ Regular expression.+      -> JSString -- ^ Potential flags.+      -> RegEx+regex re flags = _jss_re_compile re flags++-- | O(n) String substitution using regular expressions.+replace :: JSString -- ^ String perform substitution on.+        -> RegEx    -- ^ Regular expression to match.+        -> JSString -- ^ Replacement string.+        -> JSString+replace = _jss_re_replace

@@ -1,21 +1,24 @@ {-# LANGUAGE MultiParamTypeClasses, ForeignFunctionInterface, MagicHash,               TypeSynonymInstances, FlexibleInstances, EmptyDataDecls,-             UnliftedFFITypes, UndecidableInstances, CPP #-}+             UnliftedFFITypes, UndecidableInstances, CPP, OverloadedStrings #-} -- | Efficient conversions to and from JS native types. module Haste.JSType (     JSType (..), JSNum (..), toString, fromString, convert   ) where import GHC.Int import GHC.Word-import Haste.Prim (JSString, toJSStr, fromJSStr)+import Haste.Prim (JSString (..), toJSStr, fromJSStr) #ifdef __HASTE__+import Haste.Prim (JSAny (..)) import GHC.Prim import GHC.Integer.GMP.Internals import GHC.Types (Int (..)) #else+import Data.Char import GHC.Float #endif +-- | Any type which can be converted to/from a 'JSString'. class JSType a where   toJSString   :: a -> JSString   fromJSString :: JSString -> Maybe a@@ -58,6 +61,10 @@  -- JSNum instances +instance JSNum Char where+  fromNumber = unsafeCoerce# jsTrunc+  toNumber = unsafeCoerce#+ instance JSNum Int where   fromNumber = unsafeCoerce# jsTrunc   toNumber = unsafeCoerce#@@ -106,7 +113,12 @@   toNumber = id  -- JSType instances--- TODO: fromJSString is unsafe for Words; they may end up negative! fix asap!+instance JSType Bool where+  toJSString True = "true"+  toJSString _    = "false"+  fromJSString "true"  = Just True+  fromJSString "false" = Just False+  fromJSString _       = Nothing instance JSType Int where   toJSString = unsafeToJSString   fromJSString = unsafeIntFromJSString@@ -170,6 +182,10 @@                  | otherwise = Nothing  #else++instance JSNum Char where+  toNumber = fromIntegral . ord+  fromNumber = chr . round  instance JSNum Int where   toNumber = fromIntegral

@@ -1,28 +1,30 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, CPP #-} -- | Basic bindings to HTML5 WebStorage. module Haste.LocalStorage (setItem, getItem, removeItem) where import Haste import Haste.Foreign import Haste.Serialize import Haste.JSON+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif  -- | Locally store a serializable value. setItem :: Serialize a => String -> a -> IO () setItem k = store k . encodeJSON . toJSON-  where-    store :: String -> JSString -> IO ()-    store = ffi "(function(k,v) {localStorage.setItem(k,v);})" +store :: String -> JSString -> IO ()+store = ffi "(function(k,v) {localStorage.setItem(k,v);})"+ -- | Load a serializable value from local storage. Will fail if the given key --   does not exist or if the value stored at the key does not match the --   requested type. getItem :: Serialize a => String -> IO (Either String a) getItem k = do-    maybe (Left "No such value") (\s -> decodeJSON s >>= fromJSON) <$> load k-  where-    load :: String -> IO (Maybe JSString)-    load = ffi "(function(k) {return localStorage.getItem(k);})"+  maybe (Left "No such value") (\s -> decodeJSON s >>= fromJSON) <$> load k++load :: String -> IO (Maybe JSString)+load = ffi "(function(k) {return localStorage.getItem(k);})"  -- | Remove a value from local storage. removeItem :: String -> IO ()

@@ -0,0 +1,78 @@+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, TypeSynonymInstances,+             FlexibleInstances, MagicHash, GeneralizedNewtypeDeriving, CPP #-}+-- | Dealing with JavaScript objects on a low, low level.+module Haste.Object (+    JSObj, Type (..),+    (#), asString, asBool, asNumber, typeOf, lookupPath, toObject+  ) where+import Haste.Prim+import Haste.Foreign++-- | A JS object: either null/undefined or 'Just' an actual value.+type JSObj = Maybe JSAny++-- | Possible types of JS objects.+data Type = TUndefined | TNumber | TBoolean | TString | TFunction | TObject+  deriving (Show, Eq, Enum)++instance FromAny Type where+  fromAny = fmap toEnum . fromAny++-- | Any type on which we can look up a JS property.+class JSLookup a where+  infixl 4 #+  -- | Look up a property on an object-like value.+  (#) :: a -> JSString -> IO JSObj++instance JSLookup JSObj where+  Just o # prop = look o prop+  _      # _    = return Nothing++instance JSLookup a => JSLookup (IO a) where+  o # prop = o >>= (# prop)++-- | Lookup a whole path at once. More efficient for long paths.+--   @x `lookupPath` ["a", "b"]@ is equivalent to @x.a.b@.+lookupPath :: JSObj -> [JSString] -> IO JSObj+lookupPath = ffi "(function(o,as){\+                   for(var i in as){\+                     o = o[as[i]];\+                     if(typeof o==='undefined'){return null;}\+                   }\+                   return o;})"++look :: JSAny -> JSString -> IO (Maybe JSAny)+look = ffi "(function(o,s){return o[s] === undefined ? null : o[s];})"++-- | Convert the object to a 'JSString'.+asString :: JSObj -> IO (Maybe JSString)+asString = maybe (return Nothing) go+  where+    go = ffi "(function(o){return String(o);})"++-- | Convert the object to a 'Bool'.+asBool :: JSObj -> IO (Maybe Bool)+asBool = maybe (return Nothing) go+  where+    go = ffi "(function(o){return Boolean(o);})"++-- | Convert the object to a 'Double'.+asNumber :: JSObj -> IO (Maybe Double)+asNumber = maybe (return Nothing) go+  where+    go = ffi "(function(o){return Number(o);})"++-- | Get the type of a JS object.+typeOf :: JSObj -> IO Type+typeOf = maybe (return TUndefined) go+  where+    go = ffi "(function(o){\+               switch(typeof o){\+                 case 'undefined': return 0;\+                 case 'number':    return 1;\+                 case 'boolean':   return 2;\+                 case 'string':    return 3;\+                 case 'function':  return 4;\+                 default:          return 5;\+               }\+             })"

@@ -23,6 +23,10 @@     (s', x) <- m s     unP (f x) s' +instance Alternative Parse where+  empty = mzero+  (<|>) = mplus+ instance MonadPlus Parse where   mplus (Parse p1) (Parse p2) = Parse $ \s ->     case p1 s of

@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+-- | (Very incomplete) Haste bindings to the @Performance@ DOM interface.+module Haste.Performance (HRTimeStamp, now, navigationStart) where+import Haste.Foreign++type HRTimeStamp = Double++-- | Returns the number of milliseconds since 'navigationStart', with+--   (theoretically) microsecond precision.+now :: IO HRTimeStamp+now = ffi "(function(){return performance.now();})"++-- | Returns the number of milliseconds elapsed since UNIX epoch at the moment+--   when this document started loading.+navigationStart :: IO Double+navigationStart = ffi "(function(){return performance.timing.navigationStart;})"

@@ -1,40 +1,54 @@ {-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, MagicHash, -    TypeSynonymInstances, FlexibleInstances, OverlappingInstances, CPP #-}-module Haste.Prim (JSString, URL, toJSStr, fromJSStr, catJSStr, JSAny,-                   Ptr, toPtr, fromPtr) where+    TypeSynonymInstances, FlexibleInstances, CPP, UnboxedTuples #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Haste.Prim (JSString (..), URL, toJSStr, fromJSStr, catJSStr, JSAny (..),+                   Ptr, toPtr, fromPtr, veryUnsafePerformIO) where import Foreign.Ptr import Data.String #ifdef __HASTE__ import Unsafe.Coerce import GHC.CString-import GHC.Prim import qualified GHC.HastePrim as HP #else import Data.List (intercalate) #endif+import GHC.Prim+import GHC.Types (IO (..))  type URL = String-type JSAny = Ptr Haste.Prim.Any-data Any +-- | Any JS value, with one layer of indirection.+newtype JSAny = JSAny (Ptr Any)++instance Eq JSAny where+  (==) = __eq++{-# INLINE veryUnsafePerformIO #-}+-- | Strict, inlineable, dupable version of 'unsafePerformIO'. Only use if you+--   are extremely sure this is not a problem. So please don't.+veryUnsafePerformIO :: IO a -> a+veryUnsafePerformIO (IO act) =+  case act realWorld# of+    (# _, x #) -> x+ -- | Concatenate a series of JSStrings using the specified separator. catJSStr :: JSString -> [JSString] -> JSString #ifdef __HASTE__-foreign import ccall jsCat    :: Ptr [JSString] -> JSString -> JSString+foreign import ccall jsCat :: Ptr [JSString] -> JSString -> JSString+foreign import ccall __eq  :: JSAny -> JSAny -> Bool catJSStr sep strs = jsCat (toPtr strs) sep #else catJSStr sep strs = toJSStr $ intercalate (fromJSStr sep) (map fromJSStr strs)+__eq :: JSAny -> JSAny -> Bool+__eq _ _ = undefined #endif  #ifdef __HASTE__ foreign import ccall strEq :: JSString -> JSString -> Bool foreign import ccall strOrd :: JSString -> JSString -> Ptr Ordering --- | "Pointers" need to be wrapped in a data constructor.-data FakePtr a = FakePtr a--type JSString = Ptr JSChr-data JSChr+-- | Native JavaScript strings.+newtype JSString = JSString JSAny  instance Eq JSString where   (==) = strEq@@ -49,25 +63,29 @@ --   we compile to JS, however, anything can be "pointed" to and nothing needs --   to be stored. toPtr :: a -> Ptr a-toPtr = unsafeCoerce . FakePtr+toPtr = unsafeCoerce  -- | Unwrap a "pointer" to something. fromPtr :: Ptr a -> a-fromPtr ptr =-  case unsafeCoerce ptr of-    FakePtr val -> val+fromPtr = unsafeCoerce  {-# RULES "toJSS/fromJSS" forall s. toJSStr (fromJSStr s) = s #-} {-# RULES "fromJSS/toJSS" forall s. fromJSStr (toJSStr s) = s #-}-{-# RULES "toJSS/unCSTR" forall s. toJSStr (unpackCString# s) = toPtr (unsafeCoerce# s) #-}-{-# RULES "toJSS/unCSTRU8" forall s. toJSStr (unpackCStringUtf8# s) = toPtr (unsafeCoerce# s) #-}+{-# RULES "toJSS/unCSTR" forall s. toJSStr (unpackCString# s) =+    JSString (JSAny (toPtr (unsafeCoerce# s))) #-}+{-# RULES "toJSS/unCSTRU8" forall s. toJSStr (unpackCStringUtf8# s) =+    JSString (JSAny (toPtr (unsafeCoerce# s))) #-} +-- | Convert a 'String' to a 'JSString'.+{-# NOINLINE [1] toJSStr #-} toJSStr :: String -> JSString toJSStr = unsafeCoerce# HP.toJSStr  instance IsString JSString where   fromString = toJSStr +-- | Convert a 'JSString' to a 'String'.+{-# NOINLINE [1] fromJSStr #-} fromJSStr :: JSString -> String fromJSStr = unsafeCoerce# HP.fromJSStr 

@@ -14,11 +14,11 @@  #ifdef __HASTE__ -newtype Seed = Seed Unpacked deriving (Pack, Unpack)+newtype Seed = Seed JSAny deriving (ToAny, FromAny)  {-# NOINLINE nxt #-} nxt :: Seed -> IO Seed-nxt = ffi "(function(s){return md51(s.join(','));})"+nxt = ffi "(function(s){return window['md51'](s.join(','));})"  {-# NOINLINE getN #-} getN :: Seed -> IO Int@@ -26,11 +26,11 @@  {-# NOINLINE toSeed #-} toSeed :: Int -> IO Seed-toSeed = ffi "(function(n){return md51(n.toString());})"+toSeed = ffi "(function(n){return window['md51'](n.toString());})"  {-# NOINLINE createSeed #-} createSeed :: IO Seed-createSeed = ffi "(function(){return md51(jsRand().toString());})"+createSeed = ffi "(function(){return window['md51'](jsRand().toString());})" #else newtype Seed = Seed (Int, SR.StdGen) 

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, CPP #-} -- | JSON serialization and de-serialization for Haste. module Haste.Serialize (     Serialize (..), Parser, fromJSON, (.:), (.:?)@@ -7,7 +7,9 @@ import GHC.Int import Haste.JSON import Haste.Prim (JSString, toJSStr, fromJSStr)+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Monad (ap)  class Serialize a where

@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings, CPP #-}+module Haste.Timer (Timer, Interval (..), setTimer, stopTimer) where+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad.IO.Class+import Haste.Foreign+import Haste.Events.Core++type Identifier = Int++-- | Timer handle.+data Timer = Timer !Identifier !Interval++-- | Interval and repeat for timers.+data Interval+  = Once !Int   -- ^ Fire once, in n milliseconds.+  | Repeat !Int -- ^ Fire every n milliseconds.++-- | Set a timer.+setTimer :: MonadEvent m+         => Interval -- ^ Milliseconds until timer fires.+         -> m ()     -- ^ Function to call when timer fires.+         -> m Timer  -- ^ Timer handle for interacting with the timer.+setTimer i f = do+    f' <- mkHandler $ const f+    liftIO $ do+      flip Timer i <$> case i of+        Once n   -> timeout n (f' ())+        Repeat n -> interval n (f' ())++timeout :: Int -> IO () -> IO Int+timeout = ffi "(function(t,f){window.setTimeout(f,t);})"++interval :: Int -> IO () -> IO Int+interval = ffi "(function(t,f){window.setInterval(f,t);})"++-- | Stop a timer.+stopTimer :: MonadIO m => Timer -> m ()+stopTimer (Timer ident (Once _)) = liftIO $ clearTimeout ident+stopTimer (Timer ident (Repeat _)) = liftIO $ clearInterval ident++clearTimeout :: Int -> IO ()+clearTimeout = ffi "(function(id){window.clearTimeout(id);})"++clearInterval :: Int -> IO ()+clearInterval = ffi "(function(id){window.clearInterval(id);})"

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, EmptyDataDecls, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving#-} -- | WebSockets API for Haste. module Haste.WebSockets (     module Haste.Concurrent,@@ -7,37 +7,10 @@   ) where import Haste import Haste.Foreign-import Haste.Concurrent hiding (encode, decode)+import Haste.Concurrent import Haste.Binary (Blob)-import Unsafe.Coerce -newtype WSOnMsg = WSOnMsg (WebSocket -> JSString -> IO ())-newtype WSOnBinMsg = WSOnBinMsg (WebSocket -> Blob -> IO ())-newtype WSComputation = WSComputation (WebSocket -> IO ())-newtype WSOnError = WSOnError (IO ())-data WebSocket--instance Pack WebSocket where-  pack = unsafeCoerce-instance Pack WSOnMsg where-  pack = unsafeCoerce-instance Pack WSOnBinMsg where-  pack = unsafeCoerce-instance Pack WSComputation where-  pack = unsafeCoerce-instance Pack WSOnError where-  pack = unsafeCoerce--instance Unpack WebSocket where-  unpack = unsafeCoerce-instance Unpack WSOnMsg where-  unpack = unsafeCoerce-instance Unpack WSOnBinMsg where-  unpack = unsafeCoerce-instance Unpack WSComputation where-  unpack = unsafeCoerce-instance Unpack WSOnError where-  unpack = unsafeCoerce+newtype WebSocket = WebSocket JSAny deriving (ToAny, FromAny)  -- | Run a computation with a web socket. The computation will not be executed --   until a connection to the server has been established.@@ -52,11 +25,11 @@               -> CIO a withWebSocket url cb err f = do     result <- newEmptyMVar-    let f' = WSComputation $ \ws -> concurrent $ f ws >>= putMVar result-    liftIO $ new url cb' f' $ WSOnError $ concurrent $ err >>= putMVar result+    let f' = \ws -> concurrent $ f ws >>= putMVar result+    liftIO $ new url cb' f' $ concurrent $ err >>= putMVar result     takeMVar result   where-    cb' = WSOnMsg $ \ws msg -> concurrent $ cb ws msg+    cb' = \ws msg -> concurrent $ cb ws msg  -- | Run a computation with a web socket. The computation will not be executed --   until a connection to the server has been established.@@ -71,36 +44,36 @@               -> CIO a withBinaryWebSocket url cb err f = do     result <- newEmptyMVar-    let f' = WSComputation $ \ws -> concurrent $ f ws >>= putMVar result-    liftIO $ newBin url cb' f' $ WSOnError $ concurrent $ err >>= putMVar result+    let f' = \ws -> concurrent $ f ws >>= putMVar result+    liftIO $ newBin url cb' f' $ concurrent $ err >>= putMVar result     takeMVar result   where-    cb' = WSOnBinMsg $ \ws msg -> concurrent $ cb ws msg+    cb' = \ws msg -> concurrent $ cb ws msg  new :: URL-    -> WSOnMsg-    -> WSComputation-    -> WSOnError+    -> (WebSocket -> JSString -> IO ())+    -> (WebSocket -> IO ())     -> IO ()+    -> IO () new = ffi "(function(url, cb, f, err) {\              \var ws = new WebSocket(url);\-             \ws.onmessage = function(e) {B(A(cb,[ws, [0,e.data],0]));};\-             \ws.onopen = function(e) {B(A(f,[ws,0]));};\-             \ws.onerror = function(e) {B(A(err,[0]));};\+             \ws.onmessage = function(e) {cb(ws,e.data);};\+             \ws.onopen = function(e) {f(ws);};\+             \ws.onerror = function(e) {err());};\              \return ws;\            \})"   newBin :: URL-    -> WSOnBinMsg-    -> WSComputation-    -> WSOnError-    -> IO ()+       -> (WebSocket -> Blob -> IO ())+       -> (WebSocket -> IO ())+       -> IO ()+       -> IO () newBin = ffi "(function(url, cb, f, err) {\                 \var ws = new WebSocket(url);\                 \ws.binaryType = 'blob';\-                \ws.onmessage = function(e) {B(A(cb,[ws,e.data,0]));};\-                \ws.onopen = function(e) {B(A(f,[ws,0]));};\-                \ws.onerror = function(e) {B(A(err,[0]));};\+                \ws.onmessage = function(e) {cb(ws,e.data);};\+                \ws.onopen = function(e) {f(ws);};\+                \ws.onerror = function(e) {err();};\                 \return ws;\               \})"  

@@ -2,8 +2,8 @@ module Data.JSTarget (     module Constr, module Op, module Optimize, module Trav,     PPOpts (..), pretty, runPP, prettyProg, def,-    Arity, Comment, Shared, Name (..), Var (..), LHS, Call,-    Lit, Exp, Stm, Alt, AST (..), Module (..),+    Arity, Comment, Name (..), Var (..), LHS, Call,+    Lit, Exp, Stm, Alt, Module (..),     foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar, merge   ) where import Data.JSTarget.AST

@@ -1,4 +1,5 @@-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances, CPP #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances, CPP,+             OverloadedStrings #-} module Data.JSTarget.AST where import qualified Data.Set as S #if __GLASGOW_HASKELL__ >= 708@@ -6,59 +7,73 @@ #else import qualified Data.Map as M #endif-import System.IO.Unsafe-import System.Random (randomIO)-import Data.IORef-import Data.Word-import Control.Applicative import Data.JSTarget.Op+import qualified Data.ByteString as BS  type Arity = Int-type Comment = String+type Comment = BS.ByteString type Reorderable = Bool --- | Shared statements.-newtype Shared a = Shared Lbl deriving (Eq, Show)--data Name = Name !String !(Maybe (String, String)) deriving (Eq, Ord, Show)+-- | A Name consists of a variable name and optional (package, module)+--   information.+data Name = Name {+    nameIdent :: !BS.ByteString,+    nameQualifier :: !(Maybe (BS.ByteString, BS.ByteString))+  } deriving (Eq, Ord, Show)  class HasModule a where-  moduleOf :: a -> Maybe String-  pkgOf    :: a -> Maybe String+  moduleOf :: a -> Maybe BS.ByteString+  pkgOf    :: a -> Maybe BS.ByteString  instance HasModule Name where   moduleOf (Name _ mmod) = fmap snd mmod   pkgOf (Name _ mmod)    = fmap fst mmod  instance HasModule Var where-  moduleOf (Foreign _)    = Nothing-  moduleOf (Internal n _) = moduleOf n-  pkgOf (Foreign _)       = Nothing-  pkgOf (Internal n _)    = pkgOf n+  moduleOf (Foreign _)      = Nothing+  moduleOf (Internal n _ _) = moduleOf n+  pkgOf (Foreign _)         = Nothing+  pkgOf (Internal n _ _)    = pkgOf n +type KnownLoc = Bool+ -- | Representation of variables. data Var where-  Foreign  :: !String -> Var-  Internal :: !Name -> !Comment -> Var+  Foreign  :: !BS.ByteString -> Var+  -- | Being a "known location" means that we can never substitute this+  --   variable for another one, as it is used to hold "return values" from+  --   case statements, tail loopification and similar.+  --   If a variable is *not* a known location, then we may always perform the+  --   substitution @a=b ; exp => exp [a/b]@.+  Internal :: !Name -> !Comment -> !KnownLoc -> Var   deriving (Show) +isKnownLoc :: Var -> Bool+isKnownLoc (Internal _ _ knownloc) = knownloc+isKnownLoc _                       = False+ instance Eq Var where-  (Foreign f1)  == (Foreign f2)      = f1 == f2-  (Internal i1 _) == (Internal i2 _) = i1 == i2-  _ == _                             = False+  {-# INLINE (==) #-}+  (Foreign f1)  == (Foreign f2)          = f1 == f2+  (Internal i1 _ _) == (Internal i2 _ _) = i1 == i2+  _ == _                                 = False  instance Ord Var where-  compare (Foreign f1) (Foreign f2)       = compare f1 f2-  compare (Internal i1 _) (Internal i2 _) = compare i1 i2-  compare (Foreign _) (Internal _ _)      = Prelude.LT-  compare (Internal _ _) (Foreign _)      = Prelude.GT+  {-# INLINE compare #-}+  compare (Foreign f1) (Foreign f2)           = compare f1 f2+  compare (Internal i1 _ _) (Internal i2 _ _) = compare i1 i2+  compare (Foreign _) (Internal _ _ _)        = Prelude.LT+  compare (Internal _ _ _) (Foreign _)        = Prelude.GT  -- | Left hand side of an assignment. Normally we only assign internal vars, --   but for some primops we need to assign array elements as well.---   LhsExp is never reorderable. data LHS where+  -- | Introduce a new variable. May be reorderable.+  --   Invariant: a NewVar must be the first occurrence of a 'Var' in its+  --   scope.   NewVar :: !Reorderable -> !Var -> LHS-  LhsExp :: !Exp -> LHS+  -- | Assign a value to an arbitrary LHS expression. May be reorderable.+  LhsExp :: !Reorderable -> !Exp -> LHS   deriving (Eq, Show)  -- | Distinguish between normal, optimized and method calls.@@ -67,17 +82,17 @@ --   only be set to False when there is absolutely no possibility whatsoever --   that the called function will tailcall. data Call where-  Normal   :: !Bool -> Call-  Fast     :: !Bool -> Call-  Method   :: !String -> Call+  Normal   :: !Bool          -> Call+  Fast     :: !Bool          -> Call+  Method   :: !BS.ByteString -> Call   deriving (Eq, Show)  -- | Literals; nothing fancy to see here. data Lit where-  LNum  :: !Double  -> Lit-  LStr  :: !String  -> Lit-  LBool :: !Bool    -> Lit-  LInt  :: !Integer -> Lit+  LNum  :: !Double        -> Lit+  LStr  :: !BS.ByteString -> Lit+  LBool :: !Bool          -> Lit+  LInt  :: !Integer       -> Lit   LNull :: Lit   deriving (Eq, Show) @@ -85,9 +100,13 @@ data Exp where   Var       :: !Var -> Exp   Lit       :: !Lit -> Exp+  -- | A literal JS snippet.+  --   Invariant: JSLits must not perform side effects or significant+  --   computation.+  JSLit     :: !BS.ByteString -> Exp   Not       :: !Exp -> Exp   BinOp     :: !BinOp -> Exp -> !Exp -> Exp-  Fun       :: !(Maybe Name) -> ![Var] -> !Stm -> Exp+  Fun       :: ![Var] -> !Stm -> Exp   Call      :: !Arity -> !Call -> !Exp -> ![Exp] -> Exp   Index     :: !Exp -> !Exp -> Exp   Arr       :: ![Exp] -> Exp@@ -97,16 +116,27 @@   Thunk     :: !Bool -> !Stm -> Exp -- Thunk may be updatable or not   deriving (Eq, Show) +-- | Is the given expression guaranteed to not be a thunk?+--   @definitelyNotThunk e <=> safe to skip evaluation of e@+definitelyNotThunk :: Exp -> Bool+definitelyNotThunk (Lit {})   = True+definitelyNotThunk (JSLit {}) = True+definitelyNotThunk (Not {})   = True+definitelyNotThunk (BinOp {}) = True+definitelyNotThunk (Fun {})   = True+definitelyNotThunk (Arr {})   = True+definitelyNotThunk (Eval {})  = True+definitelyNotThunk _          = False+ -- | Statements. The only mildly interesting thing here are the Case and Jump --   constructors, which allow explicit sharing of continuations. data Stm where-  Case     :: !Exp -> !Stm -> ![Alt] -> !(Shared Stm) -> Stm+  Case     :: !Exp -> !Stm -> ![Alt] -> !Stm -> Stm   Forever  :: !Stm -> Stm   Assign   :: !LHS -> !Exp -> !Stm -> Stm   Return   :: !Exp -> Stm   Cont     :: Stm-  Jump     :: !(Shared Stm) -> Stm-  NullRet  :: Stm+  Stop     :: Stm -- Do nothing at all past this point   Tailcall :: !Exp -> Stm   ThunkRet :: !Exp -> Stm -- Return from a Thunk   deriving (Eq, Show)@@ -118,10 +148,10 @@ --   package, a dependency map of all its definitions, and a bunch of --   definitions. data Module = Module {-    modPackageId   :: !String,-    modName        :: !String,+    modPackageId   :: !BS.ByteString,+    modName        :: !BS.ByteString,     modDeps        :: !(M.Map Name (S.Set Name)),-    modDefs        :: !(M.Map Name (AST Exp))+    modDefs        :: !(M.Map Name Exp)   }  -- | Merge two modules. The module and package IDs of the second argument are@@ -147,31 +177,11 @@ -- | An LHS that's guaranteed to not ever be read, enabling the pretty --   printer to ignore assignments to it. blackHole :: LHS-blackHole =-  LhsExp $ Var blackHoleVar+blackHole = LhsExp False $ Var blackHoleVar  -- | The variable of the blackHole LHS. blackHoleVar :: Var-blackHoleVar = Internal (Name "" (Just ("$blackhole", "$blackhole"))) ""---- | An AST with local jumps.-data AST a = AST {-    astCode  :: !a,-    astJumps :: !JumpTable-  } deriving (Show, Eq)--instance Functor AST where-  fmap f (AST ast js) = AST (f ast) js--instance Applicative AST where-  pure = return-  (AST f js) <*> (AST x js') = AST (f x) (M.union js' js)--instance Monad AST where-  return x = AST x M.empty-  (AST ast js) >>= f =-    case f ast of-      AST ast' js' -> AST ast' (M.union js' js)+blackHoleVar = Internal (Name "" (Just ("$blackhole", "$blackhole"))) "" False  -- | Returns the precedence of the top level operator of the given expression. --   Everything that's not an operator has equal precedence, higher than any@@ -179,34 +189,6 @@ expPrec :: Exp -> Int expPrec (BinOp Sub (Lit (LNum 0)) _) = 500 -- 0-n is always printed as -n expPrec (BinOp op _ _)               = opPrec op+expPrec (AssignEx _ _)               = 0 expPrec (Not _)                      = 500 expPrec _                            = 1000--type JumpTable = M.Map Lbl Stm--data Lbl = Lbl !Word64 !Word64 deriving (Eq, Ord, Show)--{-# NOINLINE nextLbl #-}-nextLbl :: IORef Word64-nextLbl = unsafePerformIO $ newIORef 0--{-# NOINLINE lblNamespace #-}--- | Namespace for labels, to avoid collisions when combining modules.---   We really ought to make this f(package, module) or something, but a random---   64 bit unsigned int should suffice.-lblNamespace :: Word64-lblNamespace = unsafePerformIO $ randomIO--{-# NOINLINE lblFor #-}--- | Produce a local reference to the given statement.-lblFor :: Stm -> AST Lbl-lblFor s = do-    (r, s') <- freshRef-    AST r (M.singleton r s')-  where-    freshRef = return $! unsafePerformIO $! do-      r <- atomicModifyIORef nextLbl $ \lbl ->-        lbl `seq` (lbl+1, Lbl lblNamespace lbl)-      -- We need to depend on s, or GHC will hoist us out of lblFor, possibly-      -- causing circular dependencies between expressions.-      return (r, s)

@@ -8,27 +8,29 @@ import Data.JSTarget.AST import Data.JSTarget.Op -instance Binary a => Binary (AST a) where-  put (AST x jumps) = put x >> put jumps-  get = AST <$> get <*> get- instance Binary Module where   put (Module pkgid name deps defs) =     put pkgid >> put name >> put deps >> put defs   get = Module <$> get <*> get <*> get <*> get  instance Binary Var where-  put (Foreign str)           = putWord8 0 >> put str-  put (Internal name comment) = putWord8 1 >> put name >> put comment+  put (Foreign str) =+    putWord8 0 >> put str+  put (Internal name comment knownloc) =+    putWord8 1 >> put name >> put comment >> put knownloc    get = do-    getWord8 >>= ([Foreign <$> get,Internal <$> get <*> get] !!) . fromIntegral+    which <- getWord8+    case which of+      0 -> Foreign <$> get+      1 -> Internal <$> get <*> get <*> get  instance Binary LHS where   put (NewVar r v) = putWord8 0 >> put r >> put v-  put (LhsExp e)   = putWord8 1 >> put e+  put (LhsExp r e) = putWord8 1 >> put r >> put e   -  get = getWord8 >>= ([NewVar <$>get<*>get, LhsExp <$> get] !!) . fromIntegral+  get = getWord8 >>= ([NewVar <$> get <*> get,+                       LhsExp <$> get <*> get] !!) . fromIntegral  instance Binary Call where   put (Normal tr) = putWord8 0 >> put tr@@ -52,34 +54,36 @@       fromIntegral t  instance Binary Exp where-  put (Var v)           = putWord8 0 >> put v-  put (Lit l)           = putWord8 1 >> put l-  put (Not ex)          = putWord8 2 >> put ex-  put (BinOp op a b)    = putWord8 3 >> put op >> put a >> put b-  put (Fun nam as body) = putWord8 4 >> put nam >> put as >> put body-  put (Call a c f xs)   = putWord8 5 >> put a >> put c >> put f >> put xs-  put (Index arr ix)    = putWord8 6 >> put arr >> put ix-  put (Arr exs)         = putWord8 7 >> put exs-  put (AssignEx l r)    = putWord8 8 >> put l >> put r-  put (IfEx c th el)    = putWord8 9 >> put c >> put th >> put el-  put (Eval x)          = putWord8 10 >> put x-  put (Thunk upd x)     = putWord8 11 >> put upd >> put x+  put (Var v)         = putWord8 0 >> put v+  put (Lit l)         = putWord8 1 >> put l+  put (JSLit l)       = putWord8 2 >> put l+  put (Not ex)        = putWord8 3 >> put ex+  put (BinOp op a b)  = putWord8 4 >> put op >> put a >> put b+  put (Fun as body)   = putWord8 5 >> put as >> put body+  put (Call a c f xs) = putWord8 6 >> put a >> put c >> put f >> put xs+  put (Index arr ix)  = putWord8 7 >> put arr >> put ix+  put (Arr exs)       = putWord8 8 >> put exs+  put (AssignEx l r)  = putWord8 9 >> put l >> put r+  put (IfEx c th el)  = putWord8 10 >> put c >> put th >> put el+  put (Eval x)        = putWord8 11 >> put x+  put (Thunk upd x)   = putWord8 12 >> put upd >> put x      get = do     tag <- getWord8     case tag of       0  -> Var <$> get       1  -> Lit <$> get-      2  -> Not <$> get-      3  -> BinOp <$> get <*> get <*> get-      4  -> Fun <$> get <*> get <*> get-      5  -> Call <$> get <*> get <*> get <*> get-      6  -> Index <$> get <*> get-      7  -> Arr <$> get-      8  -> AssignEx <$> get <*> get-      9  -> IfEx <$> get <*> get <*> get-      10 -> Eval <$> get-      11 -> Thunk <$> get <*> get+      2  -> JSLit <$> get+      3  -> Not <$> get+      4  -> BinOp <$> get <*> get <*> get+      5  -> Fun <$> get <*> get+      6  -> Call <$> get <*> get <*> get <*> get+      7  -> Index <$> get <*> get+      8  -> Arr <$> get+      9  -> AssignEx <$> get <*> get+      10  -> IfEx <$> get <*> get <*> get+      11 -> Eval <$> get+      12 -> Thunk <$> get <*> get       n  -> error $ "Bad tag in get :: Get Exp: " ++ show n  instance Binary Stm where@@ -93,14 +97,12 @@     putWord8 3 >> put ex   put (Cont) =     putWord8 4-  put (Jump j) =-    putWord8 5 >> put j-  put (NullRet) =-    putWord8 6+  put (Stop) =+    putWord8 5   put (Tailcall ex) =-    putWord8 7 >> put ex+    putWord8 6 >> put ex   put (ThunkRet ex) =-    putWord8 8 >> put ex+    putWord8 7 >> put ex      get = do     tag <- getWord8@@ -110,10 +112,9 @@       2 -> Assign <$> get <*> get <*> get       3 -> Return <$> get       4 -> pure Cont-      5 -> Jump <$> get-      6 -> pure NullRet-      7 -> Tailcall <$> get-      8 -> ThunkRet <$> get+      5 -> pure Stop+      6 -> Tailcall <$> get+      7 -> ThunkRet <$> get       n -> error $ "Bad tag in get :: Get Stm: " ++ show n  instance Binary BinOp where@@ -127,7 +128,7 @@   put Eq     = putWord8 7   put Neq    = putWord8 8   put LT     = putWord8 9-  put GT      = putWord8 10+  put GT     = putWord8 10   put LTE    = putWord8 11   put GTE    = putWord8 12   put Shl    = putWord8 13@@ -142,14 +143,6 @@ instance Binary Name where   put (Name name owner) = put name >> put owner   get = Name <$> get <*> get--instance Binary a => Binary (Shared a) where-  put (Shared lbl) = put lbl-  get = Shared <$> get--instance Binary Lbl where-  put (Lbl namespace lbl) = put namespace >> put lbl-  get = Lbl <$> get <*> get  opTbl :: Array Word8 BinOp opTbl =

@@ -1,76 +1,96 @@-{-# LANGUAGE FlexibleInstances, OverlappingInstances, TupleSections #-}+{-# LANGUAGE FlexibleInstances, TupleSections, CPP, OverloadedStrings #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif -- | User interface for the JSTarget AST. module Data.JSTarget.Constructors where import Data.JSTarget.AST import Data.JSTarget.Op-import Control.Applicative+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as BS  -- | Literal types. class Literal a where-  lit :: a -> AST Exp+  lit :: a -> Exp +instance Literal Lit where+  lit = Lit+ instance Literal Double where-  lit = pure . Lit . LNum+  lit = lit . LNum  instance Literal Integer where-  lit = pure . Lit . LInt+  lit = lit . LInt  instance Literal Bool where-  lit = pure . Lit . LBool+  lit = lit . LBool +instance Literal BS.ByteString where+  lit = lit . LStr+ instance Literal [Char] where-  lit = pure . Lit . LStr+  lit = lit . BS.fromString +#if __GLASGOW_HASKELL__ < 710 instance Literal a => Literal [a] where-  lit xs = Arr <$> mapM lit xs+#else+instance {-# OVERLAPPABLE #-} Literal a => Literal [a] where+#endif+  lit = Arr . map lit  instance Literal Exp where-  lit = pure+  lit = id  instance Literal Var where-  lit = pure . Var+  lit = Var -litN :: Double -> AST Exp+litN :: Double -> Exp litN = lit +litS :: BS.ByteString -> Exp+litS = lit+ -- | Create a foreign variable. Foreign vars will not be subject to any name --   mangling.-foreignVar :: String -> Var+foreignVar :: BS.ByteString -> Var foreignVar = Foreign  -- | A regular, internal variable. Subject to name mangling.-internalVar :: Name -> String -> Var-internalVar = Internal+internalVar :: Name -> BS.ByteString -> Var+internalVar n c = Internal n c False +-- | A variable serving as a known location, to store return values from+--   expressions that get compiled into statements.+knownLocation :: Name -> BS.ByteString -> Var+knownLocation n c = Internal n c True+ -- | Create a name, qualified or not.-name :: String -> Maybe (String, String) -> Name+name :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) -> Name name = Name  -- | A variable expression, for convenience.-var :: Name -> String -> AST Exp-var n comment = pure $ Var $ internalVar n comment+var :: Name -> BS.ByteString -> Exp+var n comment = Var $ internalVar n comment  -- | Turn a Var into an expression.-varExp :: Var -> AST Exp-varExp = pure . Var+varExp :: Var -> Exp+varExp = Var  -- | Call to a native method on an object. Always saturated.-callMethod :: AST Exp -> String -> [AST Exp] -> AST Exp-callMethod obj meth args =-  Call 0 (Method meth) <$> obj <*> sequence args+callMethod :: Exp -> BS.ByteString -> [Exp] -> Exp+callMethod obj meth args = Call 0 (Method meth) obj args  -- | Foreign function call. Always saturated, never trampolines.-callForeign :: String -> [AST Exp] -> AST Exp-callForeign f = fmap (Call 0 (Fast False) (Var $ foreignVar f)) . sequence+callForeign :: BS.ByteString -> [Exp] -> Exp+callForeign f = Call 0 (Fast False) (Var $ foreignVar f)  -- | A normal function call. May be unsaturated. A saturated call is always --   turned into a fast call.-call :: Arity -> AST Exp -> [AST Exp] -> AST Exp-call arity f xs = do-  foldApp <$> (Call (arity - length xs) (Normal True) <$> f <*> sequence xs)+call :: Arity -> Exp -> [Exp] -> Exp+call arity f xs = foldApp $ Call (arity - length xs) (Normal True) f xs -callSaturated :: AST Exp -> [AST Exp] -> AST Exp-callSaturated f xs = Call 0 (Fast True) <$> f <*> sequence xs+callSaturated :: Exp -> [Exp] -> Exp+callSaturated f xs = Call 0 (Fast True) f xs  -- | "Fold" nested function applications into one, turning them into fast calls --   if they turn out to be saturated.@@ -80,8 +100,8 @@ foldApp (Call 0 (Normal tramp) f args) =   Call 0 (Fast tramp) f args foldApp (Call arity (Normal tramp) f args) | arity > 0 =-    Fun Nothing newargs $ Return-                        $ Call arity (Fast tramp) f (args ++ map Var newargs)+    Fun  newargs $ Return+                 $ Call arity (Fast tramp) f (args ++ map Var newargs)   where     newargs = newVars "_fa_" arity foldApp ex =@@ -90,79 +110,76 @@ -- | Introduce n new vars. newVars :: String -> Int -> [Var] newVars prefix n =-    map newVar [1..n]+    map nv [1..n]   where-    newVar i = Internal (Name (prefix ++ show i) Nothing) ""+    nv i = Internal (Name (BS.fromString $ prefix++show i) Nothing) "" False  -- | Create a thunk.-thunk :: Bool -> AST Stm -> AST Exp-thunk updatable = fmap (Thunk updatable)+thunk :: Bool -> Stm -> Exp+thunk = Thunk  -- | Evaluate an expression that may or may not be a thunk.-eval :: AST Exp -> AST Exp-eval = fmap Eval+eval :: Exp -> Exp+eval ex+  | definitelyNotThunk ex = ex+  | otherwise             = Eval ex  -- | Create a tail call.-tailcall :: AST Exp -> AST Stm-tailcall call = Tailcall <$> call+tailcall :: Exp -> Stm+tailcall = Tailcall  -- | A binary operator.-binOp :: BinOp -> AST Exp -> AST Exp -> AST Exp-binOp op a b = BinOp op <$> a <*> b+binOp :: BinOp -> Exp -> Exp -> Exp+binOp = BinOp  -- | Negate an expression.-not_ :: AST Exp -> AST Exp-not_ = fmap Not+not_ :: Exp -> Exp+not_ = Not  -- | Index into an array.-index :: AST Exp -> AST Exp -> AST Exp-index arr ix = Index <$> arr <*> ix+index :: Exp -> Exp -> Exp+index = Index  -- | Create a function.-fun :: [Var] -> AST Stm -> AST Exp-fun args = fmap (Fun Nothing args)+fun :: [Var] -> Stm -> Exp+fun = Fun  -- | Create an array of expressions.-array :: [AST Exp] -> AST Exp-array = fmap Arr . sequence+array :: [Exp] -> Exp+array = Arr  -- | Case statement. --   Takes a scrutinee expression, a default alternative, a list of more --   specific alternatives, and a continuation statement. The continuation --   will be explicitly shared among all the alternatives.-case_ :: AST Exp-      -> (AST Stm -> AST Stm)-      -> [(AST Exp, AST Stm -> AST Stm)]-      -> AST Stm-      -> AST Stm-case_ ex def alts cont = do-  ex' <- ex-  shared <- cont >>= lblFor-  let jmp = pure $ Jump (Shared shared)-  def' <- def jmp-  alts' <- sequence [(,) <$> x <*> s jmp | (x, s) <- alts]-  pure $ Case ex' def' alts' (Shared shared)+case_ :: Exp -> (Stm -> Stm) -> [(Exp, Stm -> Stm)] -> Stm -> Stm+case_ ex def alts = Case ex (def stop) (map (\(e, s) -> (e, s stop)) alts)  -- | Return from a function.-ret :: AST Exp -> AST Stm-ret = fmap Return+ret :: Exp -> Stm+ret = Return  -- | Return from a thunk.-thunkRet :: AST Exp -> AST Stm-thunkRet = fmap ThunkRet+thunkRet :: Exp -> Stm+thunkRet = ThunkRet  -- | Create a new var with a new value.-newVar :: Reorderable -> Var -> AST Exp -> AST Stm -> AST Stm-newVar r lhs = liftA2 $ \rhs -> Assign (NewVar r lhs) rhs+newVar :: Reorderable -> Var -> Exp -> Stm -> Stm+newVar r lhs = Assign (NewVar r lhs) --- | Assignment without var.-assign :: AST Exp -> AST Exp -> AST Stm -> AST Stm-assign = liftA3 $ \lhs rhs -> Assign (LhsExp lhs) rhs+-- | Reuse an old variable.+assignVar :: Reorderable -> Var -> Exp -> Stm -> Stm+assignVar r lhs = Assign (LhsExp r (Var lhs)) +-- | Assignment without var. Performed for the side effect, so never+--   reorderable.+sideEffectingAssign :: Exp -> Exp -> Stm -> Stm+sideEffectingAssign lhs = Assign (LhsExp False lhs)+ -- | Assignment expression.-assignEx :: AST Exp -> AST Exp -> AST Exp-assignEx = liftA2 AssignEx+assignEx :: Exp -> Exp -> Exp+assignEx = AssignEx  -- | Terminate a statement without doing anything at all.-nullRet :: AST Stm-nullRet = pure NullRet+stop :: Stm+stop = Stop

@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, TupleSections, DoAndIfThenElse #-}+{-# LANGUAGE PatternGuards, TupleSections, DoAndIfThenElse, OverloadedStrings #-} -- | Optimizations over the JSTarget AST. module Data.JSTarget.Optimize (     optimizeFun, tryTernary, topLevelInline@@ -10,13 +10,24 @@ import Control.Monad import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.ByteString.Char8 as BS +-- | Turn tail recursion into loops.+fixTailCalls :: Var -> Exp -> TravM Exp+fixTailCalls fun ast = do+    ast' <- assignToSubst ast >>= tailLoopify fun+    mapJS (const True) pure loopify ast'+  where+    loopify (Assign lhs@(NewVar _ f) body next) =+      Assign lhs <$> (assignToSubst body >>= tailLoopify f) <*> pure next+    loopify stm =+      return stm+ -- TODO: tryTernary may inline calls that would otherwise be in tail position --       which is something we'd really like to avoid.--optimizeFun :: Var -> AST Exp -> AST Exp-optimizeFun f (AST ast js) =-  flip runTravM js $ do+optimizeFun :: Var -> Exp -> Exp+optimizeFun f ast =+  runTravM $ do     shrinkCase ast     >>= inlineAssigns     >>= optimizeArrays@@ -24,56 +35,66 @@     >>= zapJSStringConversions     >>= optimizeThunks     >>= optimizeArrays-    >>= tailLoopify f+    >>= fixTailCalls f+    >>= inlineShortJumpTailcall     >>= trampoline     >>= ifReturnToTernary+    >>= smallStepInline+    >>= inlineJSPrimitives+    >>= mapJS (const True) pure (pure . removeNonsenseAssigns) -topLevelInline :: AST Stm -> AST Stm-topLevelInline (AST ast js) =-  flip runTravM js $ do+topLevelInline :: Stm -> Stm+topLevelInline ast =+  runTravM $ do     unTrampoline ast---    return ast+    >>= unevalLits+    >>= inlineIntoEval     >>= inlineAssigns     >>= optimizeArrays     >>= optimizeThunks+    >>= smallStepInline     >>= optimizeArrays     >>= zapJSStringConversions  -- | Attempt to turn two case branches into a ternary operator expression. tryTernary :: Var-           -> AST Exp-           -> AST Exp-           -> (AST Stm -> AST Stm)-           -> [(AST Exp, AST Stm -> AST Stm)]-           -> Maybe (AST Exp)+           -> Exp+           -> Exp+           -> (Stm -> Stm)+           -> [(Exp, Stm -> Stm)]+           -> Maybe Exp tryTernary self scrut retEx def [(m, alt)] =-    case runTravM opt allJumps of-      AST (Just ex) js -> Just (AST ex js)-      _                -> Nothing+    runTravM opt   where-    selfOccurs (Exp (Var v)) = v == self-    selfOccurs _             = False-    def' = def $ Return <$> retEx-    alt' = alt $ Return <$> retEx-    AST _ allJumps = scrut >> m >> def' >> alt'+    selfOccurs (Exp (Var v) _) = v == self+    selfOccurs _               = False+    def' = def $ Return retEx+    alt' = alt $ Return retEx     opt = do       -- Make sure the return expression is used somewhere, then cut away all       -- useless assignments. If what's left is a single Return statement,       -- we have a pure expression suitable for use with ?:.-      def'' <- inlineAssignsLocal $ astCode def'-      alt'' <- inlineAssignsLocal $ astCode alt'+      def'' <- inlineAssignsLocal def'+      alt'' <- inlineAssignsLocal alt'       -- If self occurs in either branch, we can't inline or we risk ruining       -- tail call elimination.       selfInDef <- occurrences (const True) selfOccurs def''       selfInAlt <- occurrences (const True) selfOccurs alt''       case (selfInDef + selfInAlt, def'', alt'') of         (Never, Return el, Return th) ->-          return $ Just $ IfEx (BinOp Eq (astCode scrut) (astCode m)) th el+          return $ Just $ IfEx (BinOp Eq scrut m) th el         _ ->           return Nothing tryTernary _ _ _ _ _ =   Nothing +-- | Remove bogus assignments of the form @literal = exp@, which may arise from+--   other optimizations.+removeNonsenseAssigns :: Stm -> Stm+removeNonsenseAssigns (Assign (LhsExp _ (Lit _)) _ next)    = next+removeNonsenseAssigns (Assign (LhsExp _ a) b next) | a == b = next+removeNonsenseAssigns stm                                   = stm+ -- | How many times does an expression satisfying the given predicate occur in --   an AST (including jumps)? occurrences :: JSTrav ast@@ -88,13 +109,6 @@     count n node | p node = pure $ n + Once     count n _             = pure n --- | Replace all occurrences of an expression, without entering shared code---   paths. IO ordering is preserved even when entering lambdas thanks to---   State# RealWorld.-replaceEx :: JSTrav ast => (ASTNode -> Bool) -> Exp -> Exp -> ast -> TravM ast-replaceEx trav old new =-  mapJS trav (\x -> if x == old then pure new else pure x) pure- -- | Inline assignments where the assignee is only ever used once. --   Does not inline anything into a shared code path, as that would break --   things horribly.@@ -108,39 +122,92 @@     inlinable <- gatherInlinable ast     mapJS (const True) return (inl inlinable) ast   where-    varOccurs lhs (Exp (Var lhs')) = lhs == lhs'-    varOccurs _ _                  = False-    inl m keep@(Assign (NewVar mayReorder lhs) ex next) = do-      occursRec <- occurrences (const True) (varOccurs lhs) ex-      if occursRec == Never-        then do-          occursLocal <- occurrences (not <$> isShared) (varOccurs lhs) next-          case M.lookup lhs m of-            Just occ | occ == occursLocal ->-              case occ of-                -- Inline of any non-lambda value-                Once | mayReorder -> do-                  if computingThunk ex-                    then do-                      let notSharedOrLambda = (not <$> (isShared .|. isLambda))-                      occs <- occurrences notSharedOrLambda (varOccurs lhs) next-                      if occs == Once-                        then replaceEx notSharedOrLambda (Var lhs) ex next-                        else return keep-                    else do-                      replaceEx (not <$> isShared) (Var lhs) ex next-                -- Don't inline lambdas, but use less verbose syntax.-                _    | Fun Nothing vs body <- ex,-                       Internal lhsname _ <- lhs -> do-                  return $ Assign blackHole (Fun (Just lhsname) vs body) next-                _ -> do-                  return keep-            _ ->-              return keep-        else do-          return keep+    varOccurs lhs (Exp (Var lhs') _) = lhs == lhs'+    varOccurs _ _                    = False++    appearsLHS ex =+      foldJS (\x _ -> not x) (\x s -> return $ x || ex `isLHSOf` s) False++    -- Make an exception for expressions of the form @x = E(x)@: since we know+    -- that @x@ is a literal and thus pointless to evaluate, we simply remove+    -- any such statements.+    isLHSOf v (Stm stm _) | isEvalUpd (==v) stm        = False+    isLHSOf v (Stm (Assign (LhsExp _ (Var v')) _ _) _) = v == v'+    isLHSOf v (Exp (AssignEx (Var v') _) _)            = v == v'+    isLHSOf _ _                                        = False++    inl m keep@(Assign l ex next)+      -- Inline all non-string literals l which do not appear at the LHS of an+      -- assignment. Thunk updates of the form @x = E(x)@ where @x == l@+      -- don't count as a proper LHS occurrence, and are removed outright+      -- instead since a literal is guaranteed to never be a thunk.+      | Just lhs <- inlinableAssignLHS l, Lit x <- ex, not (stringLit x) = do+        isLHS <- appearsLHS lhs next+        if isLHS+          then do+            return keep+          else do+            next' <- mapJS (const True) pure (pure . removeUpdate (==lhs)) next+            replaceEx (const True) (Var lhs) ex next'+      | Just lhs <- inlinableAssignLHS l = do+        occursRec <- occurrences (const True) (varOccurs lhs) ex+        if occursRec == Never+          then do+            occursLocal <- occurrences isSafeForInlining (varOccurs lhs) next+            case M.lookup lhs m of+              Just Once | okToInline ex && occursLocal == Once -> do+                -- Inline any non-lambda, non-thunk, non JSLit value+                replaceEx isSafeForInlining (Var lhs) ex next+              _ | Lit _ <- ex -> do+                -- Inline any string literals provided that they don't appear+                -- more than once.+                occurs <- occurrences (const True) (varOccurs lhs) next+                if occurs == Once+                  then replaceEx (const True) (Var lhs) ex next+                  else return keep+              _ -> do+                return keep+          else do+            return keep     inl _ stm = return stm +-- | Remove an occurrence of @ex = E(ex)@ or @lit = ex@.+--   Only call this for @ex@ which are guaranteed to never be thunks.+removeUpdate :: (Var -> Bool) -> Stm -> Stm+removeUpdate p stm@(Assign _ _ next) | isEvalUpd p stm = next+removeUpdate _ stm                                     = stm++-- | Turn the common pattern @var x = e ; x = E(x)@ into @var x = E(e)@.+--   should run *after* 'unevalLits'.+inlineIntoEval :: JSTrav ast => ast -> TravM ast+inlineIntoEval ast = do+    mapJS (const True) pure (pure . inline) ast+  where+    inline (Assign l@(NewVar _ v) r s@(Assign _ _ next))+      | isEvalUpd (== v) s = Assign l (Eval r) next+    inline stm             = stm++isEvalUpd :: (Var -> Bool) -> Stm -> Bool+isEvalUpd p (Assign (LhsExp _ (Var v)) (Eval (Var v')) _) = p v && v == v'+isEvalUpd _ _                                             = False++stringLit :: Lit -> Bool+stringLit (LStr _) = True+stringLit _        = False++-- | Certain expressions are never OK to inline: lambdas, thunks and+--   JS literals (which are almost exclusively lambdas).+okToInline :: Exp -> Bool+okToInline (Fun {})   = False+okToInline (Thunk {}) = False+okToInline (JSLit {}) = False+okToInline _          = True++inlinableAssignLHS :: LHS -> Maybe Var+inlinableAssignLHS (NewVar True v)       = Just v+inlinableAssignLHS (LhsExp True (Var v)) = Just v+inlinableAssignLHS _                     = Nothing+ -- | Turn if(foo) {return bar;} else {return baz;} into return foo ? bar : baz. ifReturnToTernary :: JSTrav ast => ast -> TravM ast ifReturnToTernary ast = do@@ -182,31 +249,55 @@       return x  -- | Optimize thunks in the following ways:---   A(thunk(return f), xs)---     => A(f, xs)---   E(thunk(return x))---     => x---   E(\x ... -> ...)---     => \x ... -> ...---   thunk(x) where x is non-computing and non-recursive---     => x+--   1. A(thunk(return f), xs)+--        => A(f, xs)+--   2. thunk(x@(JSLit s)) | s is a JS function object or marked eager+--        => x+--   3. thunk(x@(Lit _))+--        => x+--   4. E(thunk(return x))+--        => x+--   5. E(x) | x is guaranteed to not be a thunk+--        => x -----   TODO: figure out efficient way to only perform the 4th optimization when x---         is not recursive.+--   Note that #2 depends on the invariant of 'JSLit': a JS literal must not+--   perform side effects or significant computation. optimizeThunks :: JSTrav ast => ast -> TravM ast optimizeThunks ast =     mapJS (const True) optEx return ast   where     optEx (Eval x)-      | Just x' <- fromThunkEx x = return x'-      | Fun _ _ _ <- x           = return x-    optEx (Call arity calltype f args) | Just f' <- fromThunkEx f =-      return $ Call arity calltype f' args---    optEx ex | Just ex' <- fromThunkEx ex, not (computingEx ex') =---      return ex'-    optEx ex =-      return ex+      | Just x' <- fromThunkEx x           = return x'+      | definitelyNotThunk x               = return x+    optEx ex@(Thunk _ _)+      | Just l@(JSLit s) <- fromThunkEx ex =+        case maybeExtractStrict s of+          Just s'           -> return $ JSLit s'+          _ | isJSFunDecl s -> return l+            | otherwise     -> return ex+    optEx ex@(Thunk _ _)+      | Just l@(Lit _) <- fromThunkEx ex   = return l+    optEx (Call arity calltype f as)+      | Just f' <- fromThunkEx f           = return $ Call arity calltype f' as+    optEx ex                               = return ex +maybeExtractStrict :: BS.ByteString -> Maybe BS.ByteString+maybeExtractStrict js+  | "__strict(" `BS.isPrefixOf` js && ")" `BS.isSuffixOf` js =+    Just $ BS.init $ BS.drop 9 js+  | otherwise =+    Nothing++-- | Conservatively approximate whether a given JS literal is a function+--   declaration or not.+--+--   TODO: proper parsing here.+isJSFunDecl :: BS.ByteString -> Bool+isJSFunDecl s+  | "function(" `BS.isPrefixOf` s && "}" `BS.isSuffixOf` s  = True+  | "(function(" `BS.isPrefixOf` s && ")" `BS.isSuffixOf` s = True+  | otherwise                                               = False+ -- | Unpack the given expression if it's a thunk. fromThunk :: Exp -> Maybe Stm fromThunk (Thunk _ body) = Just body@@ -216,34 +307,12 @@ fromThunkEx :: Exp -> Maybe Exp fromThunkEx ex =   case fromThunk ex of-    Just (Return ex') -> Just ex'-    _                 -> Nothing---- | Is the given expression a thunk which when evaluated performs some kind of---   computation?-computingThunk :: Exp -> Bool-computingThunk e =-  case fromThunkEx e of-    Just e' -> computingEx e'-    _       -> False---- | Does the given expression compute something? An expression is---   non-computing if it is a variable, a literal, a lambda abstraction,---   a thunk or an array which only has non-computing elements.-computingEx :: Exp -> Bool-computingEx ex =-  case ex of-    Var _      -> False-    Lit _      -> False-    Fun _ _ _  -> False-    Thunk _ _  -> False-    Arr arr    -> any computingEx arr-    _          -> True-+    Just (Return ex')   -> Just ex'+    Just (ThunkRet ex') -> Just ex'+    _                   -> Nothing  -- | Gather a map of all inlinable symbols; that is, the ones that are used --   exactly once.---   TODO: always inline assigns that are just aliases! gatherInlinable :: JSTrav ast => ast -> TravM (M.Map Var Occs) gatherInlinable ast = do     m <- foldJS (\_ _->True) countOccs (M.empty) ast@@ -253,10 +322,14 @@     updVar _           = Just Once     updVarAss (Just o) = Just o     updVarAss _        = Just Never-    countOccs m (Exp (Var v@(Internal _ _))) =++    {-# INLINE countOccs #-}+    countOccs m (Exp (Var v@(Internal _ _ _)) _) =       pure (M.alter updVar v m)-    countOccs m (Stm (Assign (NewVar _ v) _ _)) =+    countOccs m (Stm (Assign (NewVar _ v) _ _) _) =       pure (M.alter updVarAss v m)+    countOccs m (Stm (Assign (LhsExp True (Var v)) _ _) _) =+      pure (M.alter updVarAss v m)     countOccs m _ =       pure m @@ -271,12 +344,12 @@ mayTailcall ast = do   foldJS enter countTCs False ast   where-    enter True _              = False-    enter _ (Exp (Thunk _ _)) = False---    enter _ (Exp (Fun _ _ _)) = False-    enter _ _                 = True-    countTCs _ (Stm (Tailcall _)) = return True-    countTCs acc _                = return acc+    enter True _                = False+    enter _ (Exp (Thunk _ _) _) = False+--    enter _ (Exp (Fun _ _) _)   = False+    enter _ _                   = True+    countTCs _ (Stm (Tailcall _) _) = return True+    countTCs acc _                  = return acc  -- | Gather a map of all symbols which we know will never make tail calls. --   All calls to functions in this set can then safely be de-trampolined.@@ -284,14 +357,14 @@ gatherNonTailcalling stm = do     foldJS (\_ _ -> True) countTCs S.empty stm   where-    countTCs s (Exp (Var v@(Foreign _))) = do+    countTCs s (Exp (Var v@(Foreign _)) _) = do       return $ S.insert v s-    countTCs s (Stm (Assign (NewVar _ v) (Fun _ _ body) _)) = do+    countTCs s (Stm (Assign (NewVar _ v) (Fun _ body) _) _) = do       tc <- mayTailcall body       return $ if not tc then S.insert v s else s      -    countTCs s (Exp (Fun (Just name) _ body)) = do+    countTCs s (Stm (Assign (LhsExp True (Var v)) (Fun _ body) _) _) = do       tc <- mayTailcall body-      return $ if not tc then S.insert (Internal name "") s else s+      return $ if not tc then S.insert v s else s     countTCs s _ = do       return s @@ -321,10 +394,10 @@     unTr ntcs (Call ar (Fast True) f@(Var v) xs)       | v `S.member` ntcs =         return $ Call ar (Fast False) f xs-    unTr _ c@(Call ar (Normal True) f@(Fun _ _ body) xs) = do+    unTr _ c@(Call ar (Normal True) f@(Fun _ body) xs) = do         tc <- mayTailcall body         return $ if tc then c else Call ar (Normal False) f xs-    unTr _ c@(Call ar (Fast True) f@(Fun _ _ body) xs) = do+    unTr _ c@(Call ar (Fast True) f@(Fun _ body) xs) = do         tc <- mayTailcall body         return $ if tc then c else Call ar (Fast False) f xs     unTr _ x =@@ -337,34 +410,38 @@     unTC ntcs (Tailcall c@(Call _ _ (Var v) _))       | v `S.member` ntcs =         return $ Return c-    unTC _ tc@(Tailcall c@(Call _ _ (Fun _ _ body) _)) = do+    unTC _ tc@(Tailcall c@(Call _ _ (Fun _ body) _)) = do         maytc <- mayTailcall body         if not maytc then return (Return c) else return tc     unTC _ x =         return x --- | Like `inlineAssigns`, but doesn't care what happens beyond a jump.+-- | Like 'inlineAssigns', but doesn't care what happens beyond a jump. inlineAssignsLocal :: JSTrav ast => ast -> TravM ast inlineAssignsLocal ast = do-    mapJS (\n -> not (isLambda n || isShared n)) return inl ast+    mapJS isSafeForInlining return inl ast   where-    varOccurs lhs (Exp (Var lhs')) = lhs == lhs'-    varOccurs _ _                  = False-    inl keep@(Assign (NewVar mayReorder lhs) ex next) = do-      occurs <- occurrences (const True) (varOccurs lhs) next-      occurs' <- occurrences (const True) (varOccurs lhs) ex-      case occurs + occurs' of-        Never ->-          return (Assign blackHole ex next)-        -- Don't inline lambdas at the moment, but use less verbose syntax.-        _     | Fun Nothing vs body <- ex,-                Internal lhsname _ <- lhs ->-          return $ Assign blackHole (Fun (Just lhsname) vs body) next-        Once | mayReorder ->-          -- can't be recursive - inline-          replaceEx (not <$> isShared) (Var lhs) ex next+    varOccurs lhs (Exp (Var lhs') _) = lhs == lhs'+    varOccurs _ _                    = False+    inl keep@(Assign l ex next) | Just lhs <- inlinableAssignLHS l = do+      occursRec <- occurrences (const True) (varOccurs lhs) ex+      case occursRec of+        Never -> do+          occurs <- occurrences (const True) (varOccurs lhs) next+          occursSafe <- occurrences isSafeForInlining (varOccurs lhs) next+          case (occurs, occursSafe) of+            (Never, Never) ->+              return (Assign blackHole ex next)+            _    | Fun _ _ <- ex -> do+              -- Don't inline lambdas at the moment.+              return keep+            (Once, Once) | Nothing <- fromThunk ex ->+              -- can't be recursive - inline+              replaceEx (not <$> isShared) (Var lhs) ex next+            _ ->+              -- Really nothing to be done here.+              return keep         _ ->-          -- Really nothing to be done here.           return keep     inl stm = return stm @@ -374,41 +451,52 @@ --   care about the assignment side effect. inlineReturns :: JSTrav ast => ast -> TravM ast inlineReturns ast = do-    (s, ast') <- foldMapJS (\_ _ -> True) pure2 foldRet S.empty ast-    mapM_ (flip putRef NullRet) $ S.toList s-    return ast'+    mapJS (const True) inl pure ast   where-    pure2 s x = pure (s,x)-    foldRet s (Assign (NewVar _ lhs) rhs (Return (Var v))) | v == lhs = do-      return (s, Return rhs)-    foldRet s keep@(Assign (NewVar _ lhs) rhs (Jump (Shared lbl))) = do-      next <- getRef lbl-      case next of-        Return (Var v) | v == lhs ->-          return (S.insert lbl s, Return rhs)+    inl (Fun as body)    = Fun as <$> go Nothing body+    inl (Thunk upd body) = Thunk upd <$> go Nothing body+    inl ex               = pure ex+ +    goAlt outside (ex, stm) = (ex,) <$> go outside stm++    go outside (Case c d as next) = do+      next' <- go outside next+      case returnLike next' of+        outside'@(Just _) ->+          Case c <$> go outside' d <*> mapM (goAlt outside') as <*> pure Stop         _ ->-          return (s, keep)-    foldRet s keep = do-      return (s, keep)+          Case c <$> go Nothing d <*> mapM (goAlt Nothing) as <*> pure next'+    go _ (Forever s) = do+      Forever <$> go Nothing s+    go outside (Assign l@(NewVar _ lhs) r next) = do+      next' <- go outside next+      case (next', outside) of+        (Stop, Just (Var v, ret))   | v == lhs -> return $ ret r+        (Return (Var v), _)         | v == lhs -> return $ Return r+        (ThunkRet (Var v), _)       | v == lhs -> return $ ThunkRet r+        (Assign ll (Var v) Stop, _) | v == lhs -> return $ Assign ll r Stop+        _                                      -> return $ Assign l r next'+    go outside (Assign l r next) = do+      Assign l r <$> go outside next+    go _ stm = do+      return stm --- | Inline all occurrences of the given shared code path.---   Use with caution - preferrably not at all!-inlineShared :: JSTrav ast => Lbl -> ast -> TravM ast-inlineShared lbl =-    mapJS (const True) pure inl-  where-    inl (Jump (Shared lbl')) | lbl == lbl' = getRef lbl-    inl s                                  = pure s+-- | Extract the expression returned from a Return of ThunkRet, as well as+--   a function to recreate that type of return.+returnLike :: Stm -> Maybe (Exp, Exp -> Stm)+returnLike (Return e)   = Just (e, Return)+returnLike (ThunkRet e) = Just (e, ThunkRet)+returnLike _            = Nothing  -- | Shrink case statements as much as possible. shrinkCase :: JSTrav ast => ast -> TravM ast shrinkCase =     mapJS (const True) pure shrink   where-    shrink (Case _ def [] next@(Shared lbl))-      | def == Jump next = getRef lbl-      | otherwise        = inlineShared lbl def-    shrink stm           = return stm+    shrink (Case _ def [] next)+      | def == Stop = return next+      | otherwise   = replaceFinalStm next (== Stop) def+    shrink stm      = return stm  -- | Turn any calls in tail position into tailcalls. --   Must run after @tailLoopify@ or we won't get loops for simple tail@@ -440,7 +528,7 @@ --     } --   } tailLoopify :: Var -> Exp -> TravM Exp-tailLoopify f fun@(Fun mname args body) = do+tailLoopify f fun@(Fun args body) = do     tailrecs <- occurrences (not <$> isLambda) isTailRec body     if tailrecs > Never       then do@@ -450,32 +538,30 @@             let args' = map newName args                 ret = Return (Lit $ LNull)             b <- mapJS (not <$> isLambda) pure (replaceByAssign ret args') body-            let (AST nullRetLbl _) = lblFor NullRet-                nn = newName f+            let nn = newName f                 nv = NewVar False nn                 body' =                   Forever $-                  Assign nv (Call 0 (Fast False) (Fun Nothing args b)+                  Assign nv (Call 0 (Fast False) (Fun args b)                                                  (map Var args')) $-                  Case (Var nn) (Return (Var nn)) [(Lit $ LNull, NullRet)] $-                  (Shared nullRetLbl)-            putRef nullRetLbl NullRet-            return $ Fun mname args' body'+                  Case (Var nn) (Return (Var nn)) [(Lit $ LNull, Stop)] $+                  Stop+            return $ Fun args' body'           False -> do             let c = Cont             body' <- mapJS (not <$> isLambda) pure (replaceByAssign c args) body-            return $ Fun mname args (Forever body')+            return $ Fun args (Forever body')       else do         return fun   where-    isTailRec (Stm (Return (Call _ _ (Var f') _))) = f == f'-    isTailRec _                                    = False+    isTailRec (Stm (Return (Call _ _ (Var f') _)) _) = f == f'+    isTailRec _                                      = False          -- Only traverse until we find a closure     createsClosures = foldJS (\acc _ -> not acc) isClosure False-    isClosure _ (Exp (Fun _ _ _)) = pure True-    isClosure _ (Exp (Thunk _ _)) = pure True-    isClosure acc _               = pure acc+    isClosure _ (Exp (Fun _ _) _)   = pure True+    isClosure _ (Exp (Thunk _ _) _) = pure True+    isClosure acc _                 = pure acc      -- Assign any changed vars, then loop.     replaceByAssign end as (Return (Call _ _ (Var f') as')) | f == f' = do@@ -486,24 +572,27 @@      -- Assign an expression to a variable, unless that expression happens to     -- be the variable itself.-    assignUnlessEqual (v, (Var v')) (next, final) | v == v' =-      (next, final)-    assignUnlessEqual (v, x) (next, final) | any (x `contains`) args =-      (Assign (NewVar False (newName v)) x . next,-       Assign (LhsExp (Var v)) (Var $ newName v) final)-                                  | otherwise =-      (Assign (LhsExp (Var v)) x . next, final)+    assignUnlessEqual (v, (Var v')) (next, final)+      | v == v' =+        (next, final)+    assignUnlessEqual (v, x) (next, final)+      | any (x `contains`) args =+        (Assign (NewVar False (newName v)) x . next,+         Assign (LhsExp False (Var v)) (Var $ newName v) final)+      | otherwise =+        (Assign (LhsExp False (Var v)) x . next, final)     -    newName (Internal (Name n mmod) _) =-      Internal (Name (' ':n) mmod) ""+    newName (Internal (Name n mmod) _ _) =+      Internal (Name (BS.cons ' ' n) mmod) "" True     newName n =       n          contains (Var v) var          = v == var     contains (Lit _) _            = False+    contains (JSLit _) _          = False     contains (Not x) var          = x `contains` var     contains (BinOp _ a b) var    = a `contains` var || b `contains` var-    contains (Fun _ _ _) _        = False+    contains (Fun _ _) _          = False     contains (Call _ _ f' xs) var = f' `contains` var||any (`contains` var) xs     contains (Index a i) var      = a `contains` var || i `contains` var     contains (Arr xs) var         = any (`contains` var) xs@@ -513,3 +602,161 @@     contains (Thunk _ _) _        = False tailLoopify _ fun = do   return fun++-- | Inline a tailcalled function @f@ when:+--+--   * @f@ does not refer to itself; and+--   * @f@ is defined immediately before its call site.+--     (@let f = ... in tailcall f@)+--+--   Should be called *after* 'tailLoopify' but *before* trampoline for best+--   effect.+inlineShortJumpTailcall :: JSTrav ast => ast -> TravM ast+inlineShortJumpTailcall ast = do+    mapJS (const True) return inl ast+  where+    inl stm@(Assign (NewVar _ f) (Fun as b) tc)+      | Just (f', as') <- getTailcallInfo tc, f == f' = do+        occs <- occurrences (const True) (isEqualTo f) b+        case (occs, zipAssign (map (NewVar True) as) as' b) of+          (Never, Just b') -> return b'+          _                -> return stm+    inl stm =+      return stm+    isEqualTo v' (Exp (Var v) _) = v == v'+    isEqualTo _ _                = False++-- | Extract the function being called and its argument list from a+--   @Tailcall (Call ...)@ or @Return (Call ...)@, provided that the call is+--   completely saturated.+getTailcallInfo :: Stm -> Maybe (Var, [Exp])+getTailcallInfo (Tailcall (Call 0 _ (Var f) as)) = Just (f, as)+getTailcallInfo (Return (Call 0 _ (Var f) as))   = Just (f, as)+getTailcallInfo _                                = Nothing++-- | Assign several variables, before executing a statement.+zipAssign :: [LHS] -> [Exp] -> Stm -> Maybe Stm+zipAssign l r final+  | length l == length r = Just $ go l r+  | otherwise            = Nothing+  where+    go (v:vs) (x:xs) = Assign v x (go vs xs)+    go [] []         = final+    go _ _           = error "zipAssign: different number of lhs and rhs!"++-- | Eliminate evaluation of vars that are guaranteed not to be thunks.+--   Mainly useful in 'topLevelInline'.+unevalLits :: JSTrav ast => ast -> TravM ast+unevalLits ast = do+    lits <- foldJS (\_ _ -> True) gatherLits S.empty ast+    mapJS (const True) pure (pure . removeUpdate (`S.member` lits)) ast+  where+    gatherLits s (Stm (Assign (NewVar _ v) rhs _) _)+      | definitelyNotThunk rhs         = pure $ S.insert v s+      | Var v' <- rhs, v' `S.member` s = pure $ S.insert v s+    gatherLits s _                     = pure s++-- | Inline calls to JS @eval@, @__set@, @__get@ and @__has@ and apply+--   functions for "Haste.Foreign".+inlineJSPrimitives :: JSTrav ast => ast -> TravM ast+inlineJSPrimitives =+    inlineFuns >=> optimizeThunks+  where+    inlineFuns = mapJS (const True) (return . inl) return+    inl ex@(Call _ (Fast _) (Var (Foreign fn)) args) =+      case (fn, args) of+        ("eval", [Lit (LStr s)]) -> JSLit s+        ("__app0", [f])          -> Call 0 (Fast False) f []+        ("__app1", f:xs)         -> Call 0 (Fast False) f xs+        ("__app2", f:xs)         -> Call 0 (Fast False) f xs+        ("__app3", f:xs)         -> Call 0 (Fast False) f xs+        ("__app4", f:xs)         -> Call 0 (Fast False) f xs+        ("__app5", f:xs)         -> Call 0 (Fast False) f xs+        ("__get", [o, k])        -> Index o k+        ("__set", [o, k, v])     -> AssignEx (Index o k) v+        ("__has", [o, k])        -> BinOp Neq (Index o k) (JSLit "undefined")+        _                        -> ex+    inl ex =+      ex++-- | Turn all assignments of the form @var v1 = e ; exp@ into @exp[v1/e]@,+--   provided that @v1@ is not used as a known location and @e@ is either a+--   variable or a non-string literal.+--   Also does not inline vars into lambdas.+--   Should go before 'tailLoopify'.+assignToSubst :: JSTrav ast => ast -> TravM ast+assignToSubst ast = do+    mapJS (const True) return inl ast+  where+    inl stm@(Assign (NewVar _ v) x next) | not (isKnownLoc v) = do+      case x of+        (Var _)        -> do+          -- TODO: this can be replaced by a map (to replace) and a count of+          --       remaining occurrences of v (fold)+          (c, stm') <- replaceExWithCount (isSafeForInlining) (Var v) x next+          (c', _) <- replaceExWithCount (pure True) (Var v) x next+          if c == c'+            then return stm' -- No occurrences inside lambda+            else return stm+        (Lit (LStr _)) -> return stm+        (Lit _)        -> replaceEx (pure True) (Var v) x next+        _              -> return stm+    inl stm = do+      return stm++-- | Perform various trivially correct local inlinings:+--   var x = e; return [0, e] (boxing at the end of a thunk/function)+--    => [0, e]+--   thunk(x) where x is non-computing and non-recursive+--     => x+smallStepInline :: JSTrav ast => ast -> TravM ast+smallStepInline ast = do+    mapJS (const True) return inl ast+  where+    inl (Assign (NewVar _ v) ex (Return (Arr [l@(Lit _), Var v'])))+      | v == v' =+        return (Return (Arr [l, ex]))+    inl (Assign (NewVar _ v) ex (ThunkRet (Arr [l@(Lit _), Var v'])))+      | v == v' =+        return (ThunkRet (Arr [l, ex]))+    -- Unpack thunks which don't provide actual laziness.+    inl (Assign lhs@(NewVar _ v) t@(Thunk _ _) next)+      | Just ex <- fromThunkEx t, safeToUnThunk ex = do+        case ex of+          Thunk _ _ -> return $ Assign lhs ex next+          _         -> Assign lhs ex <$> eliminateEvalOf v next+    -- Merge @a = eval(a) ; a = eval(a)@ into a single eval.+    inl stm@(Assign (LhsExp _ (Var v1)) (Eval (Var v1')) next)+      | v1 == v1' = do+        case next of+          stm'@(Assign (LhsExp _ (Var v2)) (Eval (Var v2')) _)+            | v1 == v2 && v1' == v2' -> do+              return stm'+          _ -> do+            return stm+    inl stm =+      return stm++-- | Eliminate elimination of a variable. Only use when  *absolutely certain*+--   that the variable can never be a thunk.+eliminateEvalOf :: JSTrav ast => Var -> ast -> TravM ast+eliminateEvalOf v ast = mapJS (const True) return elim ast+  where+    elim (Assign (LhsExp _ (Var v')) (Eval (Var v'')) next)+      | v' == v'' && v == v' =+        return next+    elim stm =+        return stm++-- | Is the given expression safe to extract from a thunk?+--   An expression is safe to unthunk iff evaluating it will not cause+--   computation to take place or a variable do be dereferenced.+safeToUnThunk :: Exp -> Bool+safeToUnThunk ex =+  case ex of+    Lit _      -> True+    JSLit l    -> isJSFunDecl l+    Fun _ _    -> True+    Thunk _ _  -> True+    Arr arr    -> all safeToUnThunk arr+    _          -> False