diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright Anton Ekblad 2012-2014
+Copyright Anton Ekblad 2012-2015
 
 All rights reserved.
 
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -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
diff --git a/haste-compiler.cabal b/haste-compiler.cabal
--- a/haste-compiler.cabal
+++ b/haste-compiler.cabal
@@ -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,
diff --git a/lib/Foreign.js b/lib/Foreign.js
new file mode 100644
--- /dev/null
+++ b/lib/Foreign.js
@@ -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;}
diff --git a/lib/StableName.js b/lib/StableName.js
--- a/lib/StableName.js
+++ b/lib/StableName.js
@@ -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;
 }
diff --git a/lib/endian.js b/lib/endian.js
new file mode 100644
--- /dev/null
+++ b/lib/endian.js
@@ -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;
+}
diff --git a/lib/floatdecode.js b/lib/floatdecode.js
new file mode 100644
--- /dev/null
+++ b/lib/floatdecode.js
@@ -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];
+}
diff --git a/lib/jsflow.js b/lib/jsflow.js
new file mode 100644
--- /dev/null
+++ b/lib/jsflow.js
@@ -0,0 +1,5 @@
+/* JSFlow support functions. */
+console = {
+    'log': lprint,
+    'warn': lprint
+  };
diff --git a/lib/jsstring.js b/lib/jsstring.js
new file mode 100644
--- /dev/null
+++ b/lib/jsstring.js
@@ -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;
+}
diff --git a/lib/rts.js b/lib/rts.js
--- a/lib/rts.js
+++ b/lib/rts.js
@@ -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) {
diff --git a/lib/stdlib.js b/lib/stdlib.js
--- a/lib/stdlib.js
+++ b/lib/stdlib.js
@@ -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;
 }
diff --git a/libraries/haste-lib/src/Haste.hs b/libraries/haste-lib/src/Haste.hs
--- a/libraries/haste-lib/src/Haste.hs
+++ b/libraries/haste-lib/src/Haste.hs
@@ -1,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!"
diff --git a/libraries/haste-lib/src/Haste/Ajax.hs b/libraries/haste-lib/src/Haste/Ajax.hs
--- a/libraries/haste-lib/src/Haste/Ajax.hs
+++ b/libraries/haste-lib/src/Haste/Ajax.hs
@@ -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]
diff --git a/libraries/haste-lib/src/Haste/Any.hs b/libraries/haste-lib/src/Haste/Any.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Any.hs
@@ -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 ())
diff --git a/libraries/haste-lib/src/Haste/App.hs b/libraries/haste-lib/src/Haste/App.hs
--- a/libraries/haste-lib/src/Haste/App.hs
+++ b/libraries/haste-lib/src/Haste/App.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/App/Client.hs b/libraries/haste-lib/src/Haste/App/Client.hs
--- a/libraries/haste-lib/src/Haste/App/Client.hs
+++ b/libraries/haste-lib/src/Haste/App/Client.hs
@@ -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.
diff --git a/libraries/haste-lib/src/Haste/App/Concurrent.hs b/libraries/haste-lib/src/Haste/App/Concurrent.hs
--- a/libraries/haste-lib/src/Haste/App/Concurrent.hs
+++ b/libraries/haste-lib/src/Haste/App/Concurrent.hs
@@ -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.
diff --git a/libraries/haste-lib/src/Haste/App/Events.hs b/libraries/haste-lib/src/Haste/App/Events.hs
deleted file mode 100644
--- a/libraries/haste-lib/src/Haste/App/Events.hs
+++ /dev/null
@@ -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)
diff --git a/libraries/haste-lib/src/Haste/App/Monad.hs b/libraries/haste-lib/src/Haste/App/Monad.hs
--- a/libraries/haste-lib/src/Haste/App/Monad.hs
+++ b/libraries/haste-lib/src/Haste/App/Monad.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/App/Protocol.hs b/libraries/haste-lib/src/Haste/App/Protocol.hs
--- a/libraries/haste-lib/src/Haste/App/Protocol.hs
+++ b/libraries/haste-lib/src/Haste/App/Protocol.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Audio.hs b/libraries/haste-lib/src/Haste/Audio.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Audio.hs
@@ -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)
diff --git a/libraries/haste-lib/src/Haste/Audio/Events.hs b/libraries/haste-lib/src/Haste/Audio/Events.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Audio/Events.hs
@@ -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 ()
diff --git a/libraries/haste-lib/src/Haste/Binary.hs b/libraries/haste-lib/src/Haste/Binary.hs
--- a/libraries/haste-lib/src/Haste/Binary.hs
+++ b/libraries/haste-lib/src/Haste/Binary.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Binary/Get.hs b/libraries/haste-lib/src/Haste/Binary/Get.hs
--- a/libraries/haste-lib/src/Haste/Binary/Get.hs
+++ b/libraries/haste-lib/src/Haste/Binary/Get.hs
@@ -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 ()
diff --git a/libraries/haste-lib/src/Haste/Binary/Put.hs b/libraries/haste-lib/src/Haste/Binary/Put.hs
--- a/libraries/haste-lib/src/Haste/Binary/Put.hs
+++ b/libraries/haste-lib/src/Haste/Binary/Put.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Binary/Types.hs b/libraries/haste-lib/src/Haste/Binary/Types.hs
--- a/libraries/haste-lib/src/Haste/Binary/Types.hs
+++ b/libraries/haste-lib/src/Haste/Binary/Types.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Callback.hs b/libraries/haste-lib/src/Haste/Callback.hs
deleted file mode 100644
--- a/libraries/haste-lib/src/Haste/Callback.hs
+++ /dev/null
@@ -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)
diff --git a/libraries/haste-lib/src/Haste/Compiler.hs b/libraries/haste-lib/src/Haste/Compiler.hs
--- a/libraries/haste-lib/src/Haste/Compiler.hs
+++ b/libraries/haste-lib/src/Haste/Compiler.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Compiler/Flags.hs b/libraries/haste-lib/src/Haste/Compiler/Flags.hs
--- a/libraries/haste-lib/src/Haste/Compiler/Flags.hs
+++ b/libraries/haste-lib/src/Haste/Compiler/Flags.hs
@@ -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
+  }
diff --git a/libraries/haste-lib/src/Haste/Concurrent.hs b/libraries/haste-lib/src/Haste/Concurrent.hs
--- a/libraries/haste-lib/src/Haste/Concurrent.hs
+++ b/libraries/haste-lib/src/Haste/Concurrent.hs
@@ -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.
diff --git a/libraries/haste-lib/src/Haste/Concurrent/Ajax.hs b/libraries/haste-lib/src/Haste/Concurrent/Ajax.hs
--- a/libraries/haste-lib/src/Haste/Concurrent/Ajax.hs
+++ b/libraries/haste-lib/src/Haste/Concurrent/Ajax.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Concurrent/Monad.hs b/libraries/haste-lib/src/Haste/Concurrent/Monad.hs
--- a/libraries/haste-lib/src/Haste/Concurrent/Monad.hs
+++ b/libraries/haste-lib/src/Haste/Concurrent/Monad.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/DOM.hs b/libraries/haste-lib/src/Haste/DOM.hs
--- a/libraries/haste-lib/src/Haste/DOM.hs
+++ b/libraries/haste-lib/src/Haste/DOM.hs
@@ -1,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
diff --git a/libraries/haste-lib/src/Haste/DOM/Core.hs b/libraries/haste-lib/src/Haste/DOM/Core.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/DOM/Core.hs
@@ -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)
diff --git a/libraries/haste-lib/src/Haste/DOM/JSString.hs b/libraries/haste-lib/src/Haste/DOM/JSString.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/DOM/JSString.hs
@@ -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);})"
diff --git a/libraries/haste-lib/src/Haste/Events.hs b/libraries/haste-lib/src/Haste/Events.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Events.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Events/BasicEvents.hs b/libraries/haste-lib/src/Haste/Events/BasicEvents.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Events/BasicEvents.hs
@@ -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 ()
diff --git a/libraries/haste-lib/src/Haste/Events/Core.hs b/libraries/haste-lib/src/Haste/Events/Core.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Events/Core.hs
@@ -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]);})"
diff --git a/libraries/haste-lib/src/Haste/Events/KeyEvents.hs b/libraries/haste-lib/src/Haste/Events/KeyEvents.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Events/KeyEvents.hs
@@ -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"
diff --git a/libraries/haste-lib/src/Haste/Events/MouseEvents.hs b/libraries/haste-lib/src/Haste/Events/MouseEvents.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Events/MouseEvents.hs
@@ -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"
diff --git a/libraries/haste-lib/src/Haste/Foreign.hs b/libraries/haste-lib/src/Haste/Foreign.hs
--- a/libraries/haste-lib/src/Haste/Foreign.hs
+++ b/libraries/haste-lib/src/Haste/Foreign.hs
@@ -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 []
diff --git a/libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs b/libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs
@@ -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"
diff --git a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs
--- a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs
+++ b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs
@@ -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 ()
diff --git a/libraries/haste-lib/src/Haste/Hash.hs b/libraries/haste-lib/src/Haste/Hash.hs
--- a/libraries/haste-lib/src/Haste/Hash.hs
+++ b/libraries/haste-lib/src/Haste/Hash.hs
@@ -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);})"
diff --git a/libraries/haste-lib/src/Haste/JSON.hs b/libraries/haste-lib/src/Haste/JSON.hs
--- a/libraries/haste-lib/src/Haste/JSON.hs
+++ b/libraries/haste-lib/src/Haste/JSON.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/JSString.hs b/libraries/haste-lib/src/Haste/JSString.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/JSString.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/JSType.hs b/libraries/haste-lib/src/Haste/JSType.hs
--- a/libraries/haste-lib/src/Haste/JSType.hs
+++ b/libraries/haste-lib/src/Haste/JSType.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/LocalStorage.hs b/libraries/haste-lib/src/Haste/LocalStorage.hs
--- a/libraries/haste-lib/src/Haste/LocalStorage.hs
+++ b/libraries/haste-lib/src/Haste/LocalStorage.hs
@@ -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 ()
diff --git a/libraries/haste-lib/src/Haste/Object.hs b/libraries/haste-lib/src/Haste/Object.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Object.hs
@@ -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;\
+               }\
+             })"
diff --git a/libraries/haste-lib/src/Haste/Parsing.hs b/libraries/haste-lib/src/Haste/Parsing.hs
--- a/libraries/haste-lib/src/Haste/Parsing.hs
+++ b/libraries/haste-lib/src/Haste/Parsing.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Performance.hs b/libraries/haste-lib/src/Haste/Performance.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Performance.hs
@@ -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;})"
diff --git a/libraries/haste-lib/src/Haste/Prim.hs b/libraries/haste-lib/src/Haste/Prim.hs
--- a/libraries/haste-lib/src/Haste/Prim.hs
+++ b/libraries/haste-lib/src/Haste/Prim.hs
@@ -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
 
diff --git a/libraries/haste-lib/src/Haste/Random.hs b/libraries/haste-lib/src/Haste/Random.hs
--- a/libraries/haste-lib/src/Haste/Random.hs
+++ b/libraries/haste-lib/src/Haste/Random.hs
@@ -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)
 
diff --git a/libraries/haste-lib/src/Haste/Serialize.hs b/libraries/haste-lib/src/Haste/Serialize.hs
--- a/libraries/haste-lib/src/Haste/Serialize.hs
+++ b/libraries/haste-lib/src/Haste/Serialize.hs
@@ -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
diff --git a/libraries/haste-lib/src/Haste/Timer.hs b/libraries/haste-lib/src/Haste/Timer.hs
new file mode 100644
--- /dev/null
+++ b/libraries/haste-lib/src/Haste/Timer.hs
@@ -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);})"
diff --git a/libraries/haste-lib/src/Haste/WebSockets.hs b/libraries/haste-lib/src/Haste/WebSockets.hs
--- a/libraries/haste-lib/src/Haste/WebSockets.hs
+++ b/libraries/haste-lib/src/Haste/WebSockets.hs
@@ -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;\
               \})" 
 
diff --git a/src/Data/JSTarget.hs b/src/Data/JSTarget.hs
--- a/src/Data/JSTarget.hs
+++ b/src/Data/JSTarget.hs
@@ -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
diff --git a/src/Data/JSTarget/AST.hs b/src/Data/JSTarget/AST.hs
--- a/src/Data/JSTarget/AST.hs
+++ b/src/Data/JSTarget/AST.hs
@@ -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)
diff --git a/src/Data/JSTarget/Binary.hs b/src/Data/JSTarget/Binary.hs
--- a/src/Data/JSTarget/Binary.hs
+++ b/src/Data/JSTarget/Binary.hs
@@ -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 =
diff --git a/src/Data/JSTarget/Constructors.hs b/src/Data/JSTarget/Constructors.hs
--- a/src/Data/JSTarget/Constructors.hs
+++ b/src/Data/JSTarget/Constructors.hs
@@ -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
diff --git a/src/Data/JSTarget/Optimize.hs b/src/Data/JSTarget/Optimize.hs
--- a/src/Data/JSTarget/Optimize.hs
+++ b/src/Data/JSTarget/Optimize.hs
@@ -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
diff --git a/src/Data/JSTarget/PP.hs b/src/Data/JSTarget/PP.hs
--- a/src/Data/JSTarget/PP.hs
+++ b/src/Data/JSTarget/PP.hs
@@ -13,8 +13,8 @@
 import Control.Applicative
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as BS
-import Data.JSTarget.AST (AST (..), Name (..), JumpTable, Lbl, Stm)
-import Data.JSTarget.Traversal (JSTrav)
+import Data.ByteString (ByteString)
+import Data.JSTarget.AST (Name (..))
 import Data.ByteString.Builder
 
 -- | Pretty-printing options
@@ -39,15 +39,14 @@
 newtype PP a = PP {unPP :: PPOpts
                         -> IndentLvl
                         -> NameSupply
-                        -> JumpTable
                         -> Builder
                         -> (NameSupply, Builder, a)}
 
 instance Monad PP where
-  PP m >>= f = PP $ \opts indentlvl ns js b ->
-    case m opts indentlvl ns js b of
-      (ns', b', x) -> unPP (f x) opts indentlvl ns' js b'
-  return x = PP $ \_ _ ns _ b -> (ns, b, x)
+  PP m >>= f = PP $ \opts indentlvl ns b ->
+    case m opts indentlvl ns b of
+      (ns', b', x) -> unPP (f x) opts indentlvl ns' b'
+  return x = PP $ \_ _ ns b -> (ns, b, x)
 
 instance Applicative PP where
   pure  = return
@@ -81,38 +80,34 @@
 
 -- | Generate the final name for a variable.
 finalNameFor :: Name -> PP FinalName
-finalNameFor n = PP $ \_ _ ns@(nextN, m) _ b ->
+finalNameFor n = PP $ \_ _ ns@(nextN, m) b ->
   case M.lookup n m of
     Just n' -> (ns, b, n')
     _       -> ((succ nextN, M.insert n nextN m), b, nextN)
 
--- | Look up a shared reference.
-lookupLabel :: Lbl -> PP Stm
-lookupLabel lbl = PP $ \_ _ ns js b -> (ns, b, js M.! lbl)
-
 -- | Returns the value of the given pretty-printer option.
 getOpt :: (PPOpts -> a) -> PP a
-getOpt f = PP $ \opts _ ns _ b -> (ns, b, f opts)
+getOpt f = PP $ \opts _ ns b -> (ns, b, f opts)
 
 -- | Runs the given printer iff the specifiet option is True.
 whenOpt :: (PPOpts -> Bool) -> PP () -> PP ()
 whenOpt f p = getOpt f >>= \x -> when x p
 
 -- | Pretty print an AST.
-pretty :: (JSTrav a, Pretty a) => PPOpts -> AST a -> BS.ByteString
-pretty opts (AST ast js) =
-  case runPP opts js (pp ast) of
+pretty :: Pretty a => PPOpts -> a -> BS.ByteString
+pretty opts ast =
+  case runPP opts (pp ast) of
     (b, _) -> toLazyByteString b
 
 -- | Run a pretty printer.
-runPP :: PPOpts -> JumpTable -> PP a -> (Builder, a)
-runPP opts js p =
-  case unPP p opts 0 emptyNS js mempty of
+runPP :: PPOpts -> PP a -> (Builder, a)
+runPP opts p =
+  case unPP p opts 0 emptyNS mempty of
     (_, b, x) -> (b, x)
 
 -- | Pretty-print a program and return the final name for its entry point.
-prettyProg :: Pretty a => PPOpts -> Name -> AST a -> (Builder, Builder)
-prettyProg opts mainSym (AST ast js) = runPP opts js $ do
+prettyProg :: Pretty a => PPOpts -> Name -> a -> (Builder, Builder)
+prettyProg opts mainSym ast = runPP opts $ do
   pp ast
   buildFinalName <$> finalNameFor mainSym
 
@@ -141,7 +136,9 @@
   put :: a -> PP ()
 
 instance Buildable Builder where
-  put x = PP $ \_ _ ns _ b -> (ns, b <> x, ())
+  put x = PP $ \_ _ ns b -> (ns, b <> x, ())
+instance Buildable ByteString where
+  put = put . byteString
 instance Buildable String where
   put = put . stringUtf8
 instance Buildable Char where
@@ -161,7 +158,7 @@
 
 -- | Emit indentation up to the current level.
 ind :: PP ()
-ind = PP $ \opts indentlvl ns _ b ->
+ind = PP $ \opts indentlvl ns b ->
   (ns, foldl' (<>) b (replicate indentlvl (indentStr opts)), ())
 
 -- | A space character.
diff --git a/src/Data/JSTarget/Print.hs b/src/Data/JSTarget/Print.hs
--- a/src/Data/JSTarget/Print.hs
+++ b/src/Data/JSTarget/Print.hs
@@ -1,35 +1,39 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings, CPP #-}
 module Data.JSTarget.Print () where
 import Prelude hiding (LT, GT)
 import Data.JSTarget.AST
 import Data.JSTarget.Op
 import Data.JSTarget.PP as PP
 import Data.ByteString.Builder
-import Data.Monoid
 import Control.Monad
 import Data.Char
 import Numeric (showHex)
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.UTF8 as BS
 
 instance Pretty Var where
   pp (Foreign name) =
-    put $ stringUtf8 name
-  pp (Internal name comment) = do
+    put name
+  pp (Internal name@(Name _ _) comment _) = do
     pp name
     doComment <- getOpt nameComments
-    when (doComment && not (null comment)) $
-      put $ "/* " <> stringUtf8 comment <> " */"
+    when doComment $ do
+      when (not $ BS.null comment) $ do
+        put $ byteString "/* "
+        put comment
+        put $ byteString " */"
 
 instance Pretty Name where
   pp name = finalNameFor name >>= put . buildFinalName
 
 instance Pretty LHS where
-  pp (NewVar _ v) = "var " .+. pp v
-  pp (LhsExp ex)  = pp ex
+  pp (NewVar _ v)  = "var " .+. pp v
+  pp (LhsExp _ ex) = pp ex
 
 instance Pretty Lit where
   pp (LNum d)  = put d
-  pp (LStr s)  = "\"" .+. put (fixQuotes s) .+. "\""
+  pp (LStr s)  = "\"" .+. put (fixQuotes $ BS.toString s) .+. "\""
     where
       fixQuotes ('\\':xs) = "\\\\" ++ fixQuotes xs
       fixQuotes ('"':xs)  = '\\':'"'  : fixQuotes xs
@@ -37,9 +41,9 @@
       fixQuotes ('\r':xs) = '\\':'r'  : fixQuotes xs
       fixQuotes ('\n':xs) = '\\':'n' : fixQuotes xs
       fixQuotes (x:xs)
-        | ord x <= 127 = x : fixQuotes xs
-        | otherwise    = toHex x ++ fixQuotes xs
-      fixQuotes _             = []
+        | ord x <= 127    = x : fixQuotes xs
+        | otherwise       = toHex x ++ fixQuotes xs
+      fixQuotes _         = []
   pp (LBool b) = put b
   pp (LInt n)  = put n
   pp (LNull)   = "null"
@@ -70,7 +74,9 @@
     pp v
   pp (Lit l) =
     pp l
-  pp (Not ex) =
+  pp (JSLit l) =
+    put l
+  pp (Not ex) = do
     case neg ex of
       Just ex' -> pp ex'
       _ -> if expPrec (Not ex) > expPrec ex
@@ -80,32 +86,37 @@
     case norm bop of
       BinOp op a b -> opParens op a b
       ex           -> pp ex
-  pp (Fun mname args body) = do
-      "function" .+. lambdaname .+. "(" .+. ppList sep args .+. "){" .+. newl
-      indent $ pp body
-      ind .+. "}"
-    where
-      lambdaname = maybe "" (\n -> " " .+. pp n) mname
+  pp (Fun args body) = do
+    "function(" .+. ppList sep args .+. "){" .+. newl
+    indent $ pp body
+    ind .+. "}"
   pp (Call _ call f args) = do
       case call of
         Normal True  -> "B(" .+. normalCall .+. ")"
         Normal False -> normalCall
         Fast True    -> "B(" .+. fastCall .+. ")"
         Fast False   -> fastCall
-        Method m  -> pp f .+. put ('.':m) .+. "(" .+. ppList sep args .+. ")"
+        Method m     ->
+          pp f .+. put (BS.cons '.' m) .+. "(" .+. ppList sep args .+. ")"
     where
       normalCall = "A(" .+. pp f .+. ",[" .+. ppList sep args .+. "])"
       fastCall = ppCallFun f .+. "(" .+. ppList sep args .+. ")"
-      ppCallFun fun@(Fun _ _ _) = "(" .+. pp fun .+. ")"
-      ppCallFun fun             = pp fun
-  pp (Index arr ix) = do
-    pp arr .+. "[" .+. pp ix .+. "]"
+      ppCallFun fun@(Fun _ _) = "(" .+. pp fun .+. ")"
+      ppCallFun fun           = pp fun
+  pp e@(Index arr ix) = do
+    if expPrec e > expPrec arr
+       then "(" .+. pp arr .+. ")"
+       else pp arr
+    "[" .+. pp ix .+. "]"
   pp (Arr exs) = do
     "[" .+. ppList sep exs .+. "]"
   pp (AssignEx l r) = do
     pp l .+. sp .+. "=" .+. sp .+. pp r
-  pp (IfEx c th el) = do
-    pp c .+. sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el
+  pp e@(IfEx c th el) = do
+    if expPrec e > expPrec c
+       then "(" .+. pp c .+. ")"
+       else pp c
+    sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el
   pp (Eval x) = do
     "E(" .+. pp x .+. ")"
   pp (Thunk True x) = do
@@ -134,15 +145,15 @@
 finalStm :: Stm -> PP Stm
 finalStm s =
   case s of
-    Assign _ _ s'         -> finalStm s'
-    Case _ _ _ (Shared l) -> lookupLabel l >>= finalStm
-    Forever s'            -> finalStm s'
-    _                     -> return s
+    Assign _ _ s'   -> finalStm s'
+    Case _ _ _ next -> finalStm next
+    Forever s'      -> finalStm s'
+    _               -> return s
 
 instance Pretty Stm where
-  pp (Case cond def alts (Shared nextRef)) = do
+  pp (Case cond def alts next) = do
     prettyCase cond def alts
-    lookupLabel nextRef >>= pp
+    pp next
   pp (Forever stm) = do
     line "while(1){"
     indent $ pp stm
@@ -153,17 +164,13 @@
         line (pp ex .+. ";") >> pp next
       NewVar _ _ ->
         ppAssigns s
-      LhsExp _ ->
+      LhsExp _ _ ->
         line (pp lhs .+. sp .+. "=" .+. sp .+. pp ex .+. ";") >> pp next
   pp (Return ex) = do
     line $ "return " .+. pp ex .+. ";"
   pp (Cont) = do
     line "continue;"
-  pp (Jump _) = do
-    -- Jumps are essentially fallthroughs which keep track of their
-    -- continuation to make analysis and optimization easier.
-    return ()
-  pp (NullRet) = do
+  pp (Stop) = do
     return ()
   pp (Tailcall call) = do
     line $ "return new F(function(){return " .+. pp call .+. ";});"
@@ -183,11 +190,11 @@
 prettyCase :: Exp -> Stm -> [Alt] -> PP ()
 prettyCase cond def [(con, branch)] = do
   case (def, branch) of
-    (_, NullRet) -> do
+    (_, Stop) -> do
       line $ "if(" .+. pp (neg' (test con)) .+. "){"
       indent $ pp def
       line "}"
-    (NullRet, _) -> do
+    (Stop, _) -> do
       line $ "if(" .+. pp (test con) .+. "){"
       indent $ pp branch
       line "}"
diff --git a/src/Data/JSTarget/Traversal.hs b/src/Data/JSTarget/Traversal.hs
--- a/src/Data/JSTarget/Traversal.hs
+++ b/src/Data/JSTarget/Traversal.hs
@@ -1,36 +1,18 @@
-{-# LANGUAGE FlexibleInstances, TupleSections, PatternGuards #-}
+{-# LANGUAGE FlexibleInstances, TupleSections, PatternGuards, BangPatterns #-}
 -- | Generic traversal of JSTarget AST types.
 module Data.JSTarget.Traversal where
 import Control.Applicative
 import Control.Monad
+import Control.Monad.Identity
 import Data.JSTarget.AST
-import Data.Map as M ((!), insert)
 
 -- | AST nodes we'd like to fold and map over.
-data ASTNode = Exp !Exp | Stm !Stm | Label !Lbl
-
-newtype TravM a = T (JumpTable -> (JumpTable, a))
-instance Monad TravM where
-  return x  = T $ \js -> (js, x)
-  T m >>= f = T $ \js ->
-    case m js of
-      (js', x) | T f' <- f x -> f' js'
-
-instance Applicative TravM where
-  pure  = return
-  (<*>) = ap
-
-instance Functor TravM where
-  fmap f (T m) = T $ \js -> fmap f (m js)
-
-runTravM :: TravM a -> JumpTable -> AST a
-runTravM (T f) js = case f js of (js', x) -> AST x js'
+data ASTNode = Exp !Exp !Bool | Stm !Stm !Bool | Shared !Stm
 
-getRef :: Lbl -> TravM Stm
-getRef lbl = T $ \js -> (js, js M.! lbl)
+type TravM a = Identity a
 
-putRef :: Lbl -> Stm -> TravM ()
-putRef lbl stm = T $ \js -> (M.insert lbl stm js, ())
+runTravM :: TravM a -> a
+runTravM = runIdentity
 
 class Show ast => JSTrav ast where
   -- | Bottom up transform over an AST.
@@ -59,6 +41,7 @@
 mapJS tr fe fs ast =
     snd <$> foldMapJS (const tr) (const' fe) (const' fs) () ast
   where
+    {-# INLINE const' #-}
     const' f _ x = ((),) <$> f x
 
 instance JSTrav a => JSTrav [a] where
@@ -73,200 +56,177 @@
   foldJS tr f acc ast = foldM (foldJS tr f) acc ast
 
 instance JSTrav Exp where
-  foldMapJS tr fe fs acc ast = do
-      (acc', x) <- if tr acc (Exp ast)
-                     then do
-                       case ast of
-                         v@(Var _)      -> do
-                           pure (acc, v)
-                         l@(Lit _)      -> do
-                           pure (acc, l)
-                         Not ex         -> do
-                           fmap Not <$> mapEx acc ex
-                         BinOp op a b   -> do
-                           (acc', a') <- mapEx acc a
-                           (acc'', b') <- mapEx acc' b
-                           return (acc'', BinOp op a' b')
-                         Fun nam vs stm -> do
-                           fmap (Fun nam vs) <$> foldMapJS tr fe fs acc stm
-                         Call ar c f xs -> do
-                           (acc', f') <- mapEx acc f
-                           (acc'', xs') <- foldMapJS tr fe fs acc' xs
-                           return (acc'', Call ar c f' xs')
-                         Index arr ix   -> do
-                           (acc', arr') <- mapEx acc arr
-                           (acc'', ix') <- mapEx acc' ix
-                           return (acc'', Index arr' ix')
-                         Arr exs        -> do
-                           fmap Arr <$> foldMapJS tr fe fs acc exs
-                         AssignEx l r   -> do
-                           (acc', l') <- mapEx acc l
-                           (acc'', r') <- mapEx acc' r
-                           return (acc'', AssignEx l' r')
-                         IfEx c th el   -> do
-                           (acc', c') <- mapEx acc c
-                           (acc'', th') <- mapEx acc' th
-                           (acc''', el') <- mapEx acc'' el
-                           return (acc''', IfEx c' th' el')
-                         Eval x         -> do
-                           fmap Eval <$> mapEx acc x
-                         Thunk upd x    -> do
-                           fmap (Thunk upd) <$> foldMapJS tr fe fs acc x
-                     else do
-                       return (acc, ast)
-      fe acc' x
+  foldMapJS tr fe fs = go
     where
-      mapEx = foldMapJS tr fe fs
+      go acc ast
+        | tr acc $! Exp ast False = do
+          (acc', x) <- do
+            case ast of
+              v@(Var _)      -> pure (acc, v)
+              l@(Lit _)      -> pure (acc, l)
+              l@(JSLit _)    -> pure (acc, l)
+              Not ex         -> fmap Not <$> go acc ex
+              BinOp op a b   -> do
+                (acc', a') <- go acc a
+                (acc'', b') <- go acc' b
+                return (acc'', BinOp op a' b')
+              Fun vs stm     -> fmap (Fun vs) <$> foldMapJS tr fe fs acc stm
+              Call ar c f xs -> do
+                (acc', f') <- go acc f
+                (acc'', xs') <- foldMapJS tr fe fs acc' xs
+                return (acc'', Call ar c f' xs')
+              Index arr ix   -> do
+                (acc', arr') <- go acc arr
+                (acc'', ix') <- go acc' ix
+                return (acc'', Index arr' ix')
+              Arr exs        -> fmap Arr <$> foldMapJS tr fe fs acc exs
+              AssignEx l r   -> do
+                (acc', l') <- go acc l
+                (acc'', r') <- go acc' r
+                return (acc'', AssignEx l' r')
+              IfEx c th el   -> do
+                (acc', c') <- go acc c
+                (acc'', th') <- if tr acc (Exp th True)
+                                  then go acc' th
+                                  else return (acc', th)
+                (acc''', el') <- if tr acc (Exp el True)
+                                   then go acc'' el
+                                   else return (acc'', el)
+                return (acc''', IfEx c' th' el')
+              Eval x         -> fmap Eval <$> go acc x
+              Thunk upd x    -> fmap (Thunk upd) <$> foldMapJS tr fe fs acc x
+          fe acc' x
+        | otherwise = do
+          fe acc ast
   
-  foldJS tr f acc ast = do
-    let expast = Exp ast
-    acc' <- if tr acc expast
-              then do
-                case ast of
-                  Var _         -> do
-                    return acc
-                  Lit _         -> do
-                    return acc
-                  Not ex        -> do
-                    foldJS tr f acc ex
-                  BinOp _ a b  -> do
-                    acc' <- foldJS tr f acc a
-                    foldJS tr f acc' b
-                  Fun _ _ stm    -> do
-                    foldJS tr f acc stm
-                  Call _ _ fun xs -> do
-                    acc' <- foldJS tr f acc fun
-                    foldJS tr f acc' xs
-                  Index arr ix  -> do
-                    acc' <- foldJS tr f acc arr
-                    foldJS tr f acc' ix
-                  Arr exs       -> do
-                    foldJS tr f acc exs
-                  AssignEx l r  -> do
-                    acc' <- foldJS tr f acc l
-                    foldJS tr f acc' r
-                  IfEx c th el  -> do
-                    acc' <- foldJS tr f acc c
-                    acc'' <- foldJS tr f acc' th
-                    foldJS tr f acc'' el
-                  Eval ex       -> do
-                    foldJS tr f acc ex
-                  Thunk upd stm -> do
-                    foldJS tr f acc stm
-              else do
-                return acc
-    f acc' expast
+  foldJS tr f = go
+    where
+      go acc ast
+        | tr acc $! expast = do
+          flip f expast =<< do
+            case ast of
+              Var _           -> return acc
+              Lit _           -> return acc
+              JSLit _         -> return acc
+              Not ex          -> go acc ex
+              BinOp _ a b     -> go acc a >>= flip go b
+              Fun _ stm       -> foldJS tr f acc stm
+              Call _ _ fun xs -> go acc fun >>= flip (foldJS tr f) xs
+              Index arr ix    -> go acc arr >>= flip go ix
+              Arr exs         -> foldJS tr f acc exs
+              AssignEx l r    -> go acc l >>= flip go r
+              IfEx c th el    -> do
+                acc' <- go acc c
+                acc'' <- if tr acc $! Exp th True
+                           then go acc' th
+                           else return acc'
+                if tr acc $! Exp th True
+                  then go acc'' el
+                  else return acc''
+              Eval ex         -> go acc ex
+              Thunk _upd stm  -> foldJS tr f acc stm
+        | otherwise =
+          f acc expast
+        where !expast = Exp ast False
 
 instance JSTrav Stm where
-  foldMapJS tr fe fs acc ast = do
-      (acc', x) <- if tr acc (Stm ast)
-                     then do
-                       case ast of
-                         Case ex def alts next -> do
-                           (acc', ex') <- foldMapJS tr fe fs acc ex
-                           (acc'', def') <- foldMapJS tr fe fs acc' def
-                           (acc''', alts') <- foldMapJS tr fe fs acc'' alts
-                           (acc'''', next') <- foldMapJS tr fe fs acc''' next
-                           return (acc'''', Case ex' def' alts' next')
-                         Forever stm -> do
-                           fmap Forever <$> foldMapJS tr fe fs acc stm
-                         Assign lhs ex next -> do
-                           (acc', lhs') <- foldMapJS tr fe fs acc lhs
-                           (acc'', ex') <- foldMapJS tr fe fs acc' ex
-                           (acc''', next') <- foldMapJS tr fe fs acc'' next
-                           return (acc''', Assign lhs' ex' next')
-                         Return ex -> do
-                           fmap Return <$> foldMapJS tr fe fs acc ex
-                         Cont -> do
-                           return (acc, Cont)
-                         Jump stm -> do
-                           fmap Jump <$> foldMapJS tr fe fs acc stm
-                         NullRet -> do
-                           return (acc, NullRet)
-                         Tailcall ex -> do
-                           fmap Tailcall <$> foldMapJS tr fe fs acc ex
-                         ThunkRet ex -> do
-                           fmap ThunkRet <$> foldMapJS tr fe fs acc ex
-                     else do
-                       return (acc, ast)
-      fs acc' x
+  foldMapJS tr fe fs = go
+    where
+      go acc ast
+        | tr acc $! Stm ast False = do
+          (acc', x) <- do
+            case ast of
+              Case ex def as nxt -> do
+                (acc1, ex') <- foldMapJS tr fe fs acc ex
+                (acc2, def') <- go acc1 def
+                (acc3, as') <- foldMapJS tr fe fs acc2 as
+                (acc4, nxt') <- if tr acc $! Shared nxt
+                                  then go acc3 nxt
+                                  else return (acc3, nxt)
+                return (acc4, Case ex' def' as' nxt')
+              Assign lhs ex next -> do
+                (acc', lhs') <- foldMapJS tr fe fs acc lhs
+                (acc'', ex') <- foldMapJS tr fe fs acc' ex
+                (acc''', next') <- go acc'' next
+                return (acc''', Assign lhs' ex' next')
+              Forever stm        -> fmap Forever <$> go acc stm
+              Return ex          -> fmap Return <$> foldMapJS tr fe fs acc ex
+              Cont               -> return (acc, ast)
+              Stop               -> return (acc, ast)
+              Tailcall ex        -> fmap Tailcall <$> foldMapJS tr fe fs acc ex
+              ThunkRet ex        -> fmap ThunkRet <$> foldMapJS tr fe fs acc ex
+          fs acc' x
+        | otherwise = do
+          fs acc ast
 
-  foldJS tr f acc ast = do
-    let stmast = Stm ast
-    acc' <- if tr acc stmast
-              then do
-                case ast of
-                  Case ex def alts next -> do
-                    acc' <- foldJS tr f acc ex
-                    acc'' <- foldJS tr f acc' def
-                    acc''' <- foldJS tr f acc'' alts
-                    foldJS tr f acc''' next
-                  Forever stm -> do
-                    foldJS tr f acc stm
-                  Assign lhs ex next -> do
-                    acc' <- foldJS tr f acc lhs
-                    acc'' <- foldJS tr f acc' ex
-                    foldJS tr f acc'' next
-                  Return ex -> do
-                    foldJS tr f acc ex
-                  Cont -> do
-                    return acc
-                  Jump j -> do
-                    foldJS tr f acc j
-                  NullRet -> do
-                    return acc
-                  Tailcall ex -> do
-                    foldJS tr f acc ex
-                  ThunkRet ex -> do
-                    foldJS tr f acc ex
-              else do
-                return acc
-    f acc' stmast
+  foldJS tr f = go
+    where
+      go acc ast
+        | tr acc stmast = do
+          flip f stmast =<< do
+            case ast of
+              Case ex def as nxt -> do
+                acc' <- foldJS tr f acc ex >>= flip go def
+                acc'' <- foldJS tr f acc' as
+                if tr acc $! Shared nxt
+                  then go acc'' nxt
+                  else return acc''
+              Assign lhs ex next -> do
+                foldJS tr f acc lhs >>= flip (foldJS tr f) ex >>= flip go next
+              Forever stm        -> foldJS tr f acc stm
+              Return ex          -> foldJS tr f acc ex
+              Cont               -> return acc
+              Stop               -> return acc
+              Tailcall ex        -> foldJS tr f acc ex
+              ThunkRet ex        -> foldJS tr f acc ex
+        | otherwise =
+          f acc stmast
+        where !stmast = Stm ast False
 
 instance JSTrav (Exp, Stm) where
   foldMapJS tr fe fs acc (ex, stm) = do
-    (acc', stm') <- foldMapJS tr fe fs acc stm
-    (acc'', ex') <- foldMapJS tr fe fs acc' ex
+    (acc', stm') <- if tr acc (Stm stm True)
+                      then foldMapJS tr fe fs acc stm
+                      else return (acc, stm)
+    (acc'', ex') <- if tr acc (Exp ex True)
+                      then foldMapJS tr fe fs acc' ex
+                      else return (acc', ex)
     return (acc'', (ex', stm'))
   foldJS tr f acc (ex, stm) = do
-    acc' <- foldJS tr f acc stm
-    foldJS tr f acc' ex
+    acc' <- if tr acc (Stm stm True)
+              then foldJS tr f acc stm
+              else return acc
+    if tr acc (Exp ex True)
+      then foldJS tr f acc' ex
+      else return acc'
 
 instance JSTrav LHS where
-  foldMapJS _ _ _ acc lhs@(NewVar _ _) = return (acc, lhs)
-  foldMapJS t fe fs a (LhsExp ex)      = fmap LhsExp <$> foldMapJS t fe fs a ex
-  foldJS _ _ acc (NewVar _ _)  = return acc
-  foldJS tr f acc (LhsExp ex)  = foldJS tr f acc ex
-
-instance JSTrav a => JSTrav (Shared a) where
-  foldMapJS tr fe fs acc sh@(Shared lbl) = do
-    if (tr acc (Label lbl)) 
-      then do
-        stm <- getRef lbl
-        (acc', stm') <- foldMapJS tr fe fs acc stm
-        putRef lbl stm'
-        return (acc', sh)
-      else do
-        return (acc, sh)
-  foldJS tr f acc (Shared lbl) = do
-    if (tr acc (Label lbl))
-      then getRef lbl >>= foldJS tr f acc >>= \acc' -> f acc' (Label lbl)
-      else f acc (Label lbl)
+  foldMapJS _ _ _ acc lhs@(NewVar _ _) =
+    return (acc, lhs)
+  foldMapJS t fe fs a (LhsExp r ex) =
+    fmap (LhsExp r) <$> foldMapJS t fe fs a ex
+  foldJS _ _ acc (NewVar _ _)    = return acc
+  foldJS tr f acc (LhsExp _ ex)  = foldJS tr f acc ex
 
 -- | Returns the final statement of a line of statements.
 finalStm :: Stm -> TravM Stm
 finalStm = go
   where
-    go (Case _ _ _ (Shared next)) = getRef next >>= go
-    go (Forever s)                = go s
-    go (Assign _ _ next)          = go next
-    go (Jump (Shared next))       = getRef next >>= go
-    go s@(Return _)               = return s
-    go (Cont)                     = return Cont
-    go (NullRet)                  = return NullRet
-    go s@(Tailcall _)             = return s
-    go s@(ThunkRet _)             = return s
+    go (Case _ _ _ next) = go next
+    go (Forever s)       = go s
+    go (Assign _ _ next) = go next
+    go s                 = return s
 
+-- | Replace the final statement of the given AST with a new one, but only
+--   if matches the given predicate.
+replaceFinalStm :: Stm -> (Stm -> Bool) -> Stm -> TravM Stm
+replaceFinalStm new p = go
+  where
+    go (Case c d as next) = Case c d as <$> go next
+    go (Forever s)        = Forever <$> go s
+    go (Assign l r next)  = Assign l r <$> go next
+    go s                  = return $ if p s then new else s
+
 -- | Returns statement's returned expression, if any.
 finalExp :: Stm -> TravM (Maybe Exp)
 finalExp stm = do
@@ -280,31 +240,49 @@
   (.&.) :: a -> a -> a
 
 instance Pred (a -> b -> Bool) where
+  {-# INLINE (.|.) #-}
+  {-# INLINE (.&.) #-}
   p .|. q = \a b -> p a b || q a b
   p .&. q = \a b -> p a b && q a b
 
 instance Pred (a -> Bool) where
+  {-# INLINE (.|.) #-}
+  {-# INLINE (.&.) #-}
   p .|. q = \a -> p a || q a
   p .&. q = \a -> p a && q a
 
-isShared :: ASTNode -> Bool
-isShared (Label _) = True
-isShared _         = False
-
 -- | Thunks and explicit lambdas count as lambda abstractions.
+{-# INLINE isLambda #-}
 isLambda :: ASTNode -> Bool
-isLambda (Exp (Fun _ _ _)) = True
-isLambda (Exp (Thunk _ _)) = True
-isLambda _                 = False
+isLambda (Exp (Fun _ _) _)   = True
+isLambda (Exp (Thunk _ _) _) = True
+isLambda _                   = False
 
-isJump :: ASTNode -> Bool
-isJump (Stm (Jump _)) = True
-isJump _              = False
+{-# INLINE isLoop #-}
+isLoop :: ASTNode -> Bool
+isLoop (Stm (Forever _) _) = True
+isLoop _                   = False
 
+{-# INLINE isConditional #-}
+isConditional :: ASTNode -> Bool
+isConditional (Exp _ cond) = cond
+isConditional (Stm _ cond) = cond
+isConditional _            = False
+
+{-# INLINE isShared #-}
+isShared :: ASTNode -> Bool
+isShared (Shared _) = True
+isShared _          = False
+
+{-# INLINE isSafeForInlining #-}
+isSafeForInlining :: ASTNode -> Bool
+isSafeForInlining = not <$> isLambda .|. isLoop .|. isShared
+
 -- | Counts occurrences. Use ints or something for a more exact count.
 data Occs = Never | Once | Lots deriving (Eq, Show)
 
 instance Ord Occs where
+  {-# INLINE compare #-}
   compare Never Once = Prelude.LT
   compare Never Lots = Prelude.LT
   compare Once  Lots = Prelude.LT
@@ -324,7 +302,35 @@
   x * Once  = x
   _ * _     = Lots
 
+  Never - _ = Never
+  x - Never = x
+  Once - _  = Never
+  Lots - _  = Lots
+
   abs = id
 
   signum Never = Never
   signum _     = Once
+
+-- | 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
+
+-- | Replace all occurrences of an expression, without entering shared code
+--   paths. IO ordering is preserved even when entering lambdas thanks to
+--   State# RealWorld.
+replaceExWithCount :: JSTrav ast
+                   => (ASTNode -> Bool) -- ^ Which nodes to enter?
+                   -> Exp               -- ^ Expression to replace.
+                   -> Exp               -- ^ Replacement expression.
+                   -> ast               -- ^ AST to perform replacement on.
+                   -> TravM (Int, ast)  -- ^ New AST + count of replacements.
+replaceExWithCount trav old new ast =
+    foldMapJS (const trav) rep (\count x -> return (count, x)) 0 ast
+  where
+    rep count ex
+      | ex == old = return (count+1, new)
+      | otherwise = return (count, ex)
diff --git a/src/Haste/Builtins.hs b/src/Haste/Builtins.hs
--- a/src/Haste/Builtins.hs
+++ b/src/Haste/Builtins.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- | Various functions generated as builtins
 module Haste.Builtins (toBuiltin) where
 import GhcPlugins as P
diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs
--- a/src/Haste/CodeGen.hs
+++ b/src/Haste/CodeGen.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections, PatternGuards, CPP #-}
+{-# LANGUAGE TupleSections, PatternGuards, CPP, OverloadedStrings #-}
 module Haste.CodeGen (generate) where
 -- Misc. stuff
 import Control.Applicative
@@ -9,32 +9,19 @@
 import Data.Char
 import Data.List (partition, foldl')
 import Data.Maybe (isJust)
-#if __GLASGOW_HASKELL__ >= 707
-import qualified Data.ByteString.UTF8 as B
-#endif
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.UTF8 as BS
 import qualified Data.Set as S
 import qualified Data.Map as M
+
 -- STG/GHC stuff
-import StgSyn
-import CoreSyn (AltCon (..))
-import Var (Var, varType, varName)
-import IdInfo (arityInfo, IdDetails (..))
-import Id (Id, idInfo, idDetails, isLocalId, isGlobalId)
-import Literal as L
+import Language.Haskell.GHC.Simple as GHC
 import FastString (unpackFS)
-import ForeignCall (CCallTarget (..), ForeignCall (..), CCallSpec (..))
-import PrimOp (PrimCall (..))
-import OccName
-import DataCon
-import Module
-import Name
-import Type
-import TysPrim
-import TyCon
-import BasicTypes
+
 -- AST stuff
 import Data.JSTarget as J hiding ((.&.))
-import Data.JSTarget.AST (Exp (..), Stm (..), LHS (..))
+import Data.JSTarget.AST as J (Exp (..), Stm (..), LHS (..))
+
 -- General Haste stuff
 import Haste.Config
 import Haste.Monad
@@ -42,47 +29,44 @@
 import Haste.PrimOps
 import Haste.Builtins
 
-generate :: Config
-         -> String
-         -> ModuleName
-         -> [StgBinding]
-         -> J.Module
-generate cfg pkgid modname binds =
-  Module {
-      modPackageId   = pkgid,
-      modName        = moduleNameString modname,
+-- | Generate an abstract JS module from a codegen config and an STG module.
+generate :: Config -> StgModule -> J.Module
+generate cfg stg =
+  J.Module {
+      modPackageId   = BS.fromString $ GHC.modPackageKey stg,
+      J.modName      = BS.fromString $ GHC.modName stg,
       modDeps        = foldl' insDep M.empty theMod,
       modDefs        = foldl' insFun M.empty theMod
     }
   where
-    theMod = genAST cfg modname binds
+    opt = if optimize cfg then optimizeFun else const id
+    theMod = genAST cfg (GHC.modName stg) (modCompiledModule stg)
 
-    insFun m (_, AST (Assign (NewVar _ (Internal v _)) body _) jumps) =
-      M.insert v (AST body jumps) m
+    insFun m (_, Assign (NewVar _ v@(Internal n _ _)) body _) =
+      M.insert n (opt v body) m
     insFun m _ =
       m
 
     -- TODO: perhaps do dependency-based linking for externals as well?
-    insDep m (ds, AST (Assign (NewVar _ (Internal v _)) _ _) _) =
+    insDep m (ds, Assign (NewVar _ (Internal v _ _)) _ _) =
       M.insert v (S.delete v ds) m
     insDep m _ =
       m
 
 -- | Generate JS AST for bindings.
-genAST :: Config -> ModuleName -> [StgBinding] -> [(S.Set J.Name, AST Stm)]
+genAST :: Config -> String -> [StgBinding] -> [(S.Set J.Name, Stm)]
 genAST cfg modname binds =
     binds'
   where
     binds' =
-      map (depsAndCode . genJS cfg myModName . uncurry (genBind True))
+      map (depsAndCode . genJS cfg modname . uncurry (genBind True))
       $ concatMap unRec
       $ binds
-    myModName = moduleNameString modname
-    depsAndCode (_, ds, locs, stm) = (ds S.\\ locs, stm nullRet)
+    depsAndCode (_, ds, locs, stm) = (ds S.\\ locs, stm stop)
 
 -- | Check for builtins that should generate inlined code. At this point only
 --   w2i and i2w.
-genInlinedBuiltin :: Var.Var -> [StgArg] -> JSGen Config (Maybe (AST Exp))
+genInlinedBuiltin :: GHC.Var -> [StgArg] -> JSGen Config (Maybe Exp)
 genInlinedBuiltin f [x] = do
     x' <- genArg x
     return $ case (modname, varname) of
@@ -93,14 +77,14 @@
       _ ->
         Nothing
   where
-    modname = moduleNameString . moduleName <$> nameModule_maybe (Var.varName f)
-    varname = occNameString $ nameOccName $ Var.varName f
+    modname = moduleNameString . moduleName <$> nameModule_maybe (GHC.varName f)
+    varname = occNameString $ nameOccName $ GHC.varName f
 genInlinedBuiltin _ _ =
   return Nothing
 
 
 -- | Generate code for an STG expression.
-genEx :: StgExpr -> JSGen Config (AST Exp)
+genEx :: StgExpr -> JSGen Config Exp
 genEx (StgApp f xs) = do
   mex <- genInlinedBuiltin f xs
   case mex of
@@ -119,7 +103,7 @@
       (tag, stricts) <- genDataCon con
       (args', stricts') <- genArgsPair $ zip args stricts
       -- Don't create unboxed tuples with a single element.
-      case (isUnboxedTupleCon con, args') of
+      case (isNewtypeLikeCon con || isUnboxedTupleCon con, args') of
         (True, [arg]) -> return $ evaluate arg (head stricts')
         _             -> mkCon tag args' stricts'
   where
@@ -139,17 +123,14 @@
   cfg <- getCfg
   let theOp = case op of
         StgPrimOp op' ->
-          maybeTrace cfg (showOutputable cfg op') args' <$> genOp cfg op' args'
+          maybeTrace cfg opstr args' <$> genOp cfg op' args'
+          where opstr = BS.fromString $ showOutputable cfg op'
         StgPrimCallOp (PrimCall f _) ->
           Right $ maybeTrace cfg fs args' $ callForeign fs args'
-          where fs = unpackFS f
-#if __GLASGOW_HASKELL__ >= 706
+          where fs = BS.fromString $ unpackFS f
         StgFCallOp (CCall (CCallSpec (StaticTarget f _ _) _ _)) _t ->
-#else
-        StgFCallOp (CCall (CCallSpec (StaticTarget f _) _ _)) _t ->
-#endif
           Right $ maybeTrace cfg fs args' $ callForeign fs args'
-          where fs = unpackFS f
+          where fs = BS.fromString $ unpackFS f
         _ ->
           error $ "Tried to generate unsupported dynamic foreign call!"
   case theOp of
@@ -163,19 +144,21 @@
   genEx ex
 genEx (StgCase ex _ _ bndr _ t alts) = do
   genCase t ex bndr alts
+  
+#if __GLASGOW_HASKELL__ < 710
+-- StgSCC is gone in 7.10, and StgTick has an argument less.
 genEx (StgSCC _ _ _ ex) = do
   genEx ex
 genEx (StgTick _ _ ex) = do
+#else
+genEx (StgTick _ ex) = do
+#endif
   genEx ex
-#if __GLASGOW_HASKELL__ >= 706
+
 genEx (StgLam _ _) = do
   error "StgLam caught during code generation - that's impossible!"
-#else
-genEx (StgLam _ _ _) = do
-  error "StgLam caught during code generation - that's impossible!"
-#endif
 -- | Trace the given expression, if tracing is on.
-maybeTrace :: Config -> String -> [AST Exp] -> AST Exp -> AST Exp
+maybeTrace :: Config -> BS.ByteString -> [Exp] -> Exp -> Exp
 maybeTrace cfg msg args ex =
   if tracePrimops cfg
     then callForeign "__h_trace" [lit msg, array args, ex]
@@ -204,14 +187,12 @@
     addLocal v'
   expr <- genRhs (isJust funsInRecGroup) rhs
   popBind
-  opt <- optimize `fmap` getCfg
-  let expr' = if opt then optimizeFun v' expr else expr
-  continue $ newVar True v' expr'
+  continue $ newVar True v' expr
 genBind _ _ (StgRec _) =
   error $  "genBind got recursive bindings!"
 
 -- | Generate the RHS of a binding.
-genRhs :: Bool -> StgRhs -> JSGen Config (AST Exp)
+genRhs :: Bool -> StgRhs -> JSGen Config Exp
 genRhs recursive (StgRhsCon _ con args) = do
   -- Constructors are never partially applied, and we have arguments, so this
   -- is obviously a full application.
@@ -227,10 +208,10 @@
                then thunk' upd (body' $ thunkRet retExp)
                else fun args' (body' $ ret retExp)
   where
-    thunk' _ (AST (Return l@(Lit _)) js) = AST l js
-    thunk' Updatable stm                 = thunk True stm
-    thunk' ReEntrant stm                 = thunk True stm
-    thunk' SingleEntry stm               = thunk False stm
+    thunk' _ (Return l@(J.Lit _)) = l
+    thunk' Updatable stm          = thunk True stm
+    thunk' ReEntrant stm          = thunk True stm
+    thunk' SingleEntry stm        = thunk False stm
 
 -- | Turn a recursive binding into a list of non-recursive ones, together with
 --   information about whether they came from a recursive group or not.
@@ -245,51 +226,64 @@
 --   Lists of vars are often accompanied by lists of strictness or usage
 --   annotations, which need to be filtered for types without representation
 --   as well.
-genArgVarsPair :: [(Var.Var, a)] -> JSGen Config ([J.Var], [a])
+genArgVarsPair :: [(GHC.Var, a)] -> JSGen Config ([J.Var], [a])
 genArgVarsPair vps = do
     vs' <- mapM genVar vs
     return (vs', xs)
   where
     (vs, xs) = unzip $ filter (hasRepresentation . fst) vps
 
-genCase :: AltType -> StgExpr -> Id -> [StgAlt] -> JSGen Config (AST Exp)
+genCase :: AltType -> StgExpr -> Id -> [StgAlt] -> JSGen Config Exp
 genCase t ex scrut alts = do
   ex' <- genEx ex
+  -- Return a scrutinee variable and a function to replace all occurrences of
+  -- the STG scrutinee with our JS one, if needed.
+  (scrut', withScrutinee) <- case ex' of
+    Eval (J.Var v) -> do
+      continue $ assignVar (reorderableType scrut) v ex'
+      oldscrut <- genVar scrut
+      return (v, rename oldscrut v)
+    _ -> do
+      scrut' <- genVar scrut
+      addLocal scrut'
+      continue $ newVar (reorderableType scrut) scrut' ex'
+      return (scrut', id)
   -- If we have a unary unboxed tuple, we want to eliminate the case
   -- entirely (modulo evaluation), so just generate the expression in the
   -- sole alternative.
-  case (isUnaryUnboxedTuple scrut, alts) of
-    (True, [(_, as, _, expr)]) | [arg] <- filter hasRepresentation as -> do
-      scrut' <- genVar scrut
-      arg' <- genVar arg
-      addLocal [scrut', arg']
-      continue (newVar (reorderableType scrut) scrut' ex')
-      continue (newVar (reorderableType scrut) arg' (varExp scrut'))
-      genEx expr
-    (True, _) -> do
+  withScrutinee $ do
+    case (isNewtypeLike scrut, isUnaryUnboxedTuple scrut, alts) of
+      (_, True, [(_, as, _, expr)]) | [arg] <- filter hasRepresentation as -> do
+        arg' <- genVar arg
+        addLocal arg'
+        continue $ newVar (reorderableType scrut) arg' (varExp scrut')
+        genEx expr
+      (True, _, [(_, [arg], _, expr)]) -> do
+        arg' <- genVar arg
+        addLocal arg'
+        continue $ newVar (reorderableType scrut) arg' (varExp scrut')
+        genEx expr
+      (_, True, _) -> do
         error "Case on unary unboxed tuple with more than one alt! WTF?!"
-    _ -> do
-      -- Generate scrutinee and result vars
-      scrut' <- genVar scrut
-      res <- genResultVar scrut
-      addLocal [scrut', res]
-      -- Split alts into default and general, and generate code for them
-      let (defAlt, otherAlts) = splitAlts alts
-          scrutinee = cmp (varExp scrut')
-      (_, defAlt') <- genAlt scrut' res defAlt
-      alts' <- mapM (genAlt scrut' res) otherAlts
-      -- Use the ternary operator where possible.
-      useSloppyTCE <- sloppyTCE `fmap` getCfg
-      self <- if useSloppyTCE then return blackHoleVar else getCurrentBinding
-      case tryTernary self scrutinee (varExp res) defAlt' alts' of
-        Just ifEx -> do
-          continue $ newVar (reorderableType scrut) scrut' ex'
-          continue $ newVar True res ifEx
-          return (varExp res)
-        _ -> do
-          continue $ newVar (reorderableType scrut) scrut' ex'
-          continue $ case_ scrutinee defAlt' alts'
-          return (varExp res)
+      _ -> do
+        -- Generate scrutinee and result vars
+        res <- genResultVar scrut
+        addLocal res
+        -- Split alts into default and general, and generate code for them
+        let (defAlt, otherAlts) = splitAlts alts
+            scrutinee = cmp (varExp scrut')
+        (_, defAlt') <- genAlt scrut' res defAlt
+        alts' <- mapM (genAlt scrut' res) otherAlts
+        -- Use the ternary operator where possible.
+        useSloppyTCE <- sloppyTCE `fmap` getCfg
+        self <- if useSloppyTCE then return blackHoleVar else getCurrentBinding
+        case tryTernary self scrutinee (varExp res) defAlt' alts' of
+          Just ifEx -> do
+            continue $ newVar True res ifEx
+            return (varExp res)
+          _ -> do
+            continue $ case_ scrutinee defAlt' alts'
+            return (varExp res)
   where
     getTag s = index s (litN 0)
     cmp = case t of
@@ -311,7 +305,7 @@
     isDefault (DEFAULT, _, _, _) = True
     isDefault _                  = False
 
-genAlt :: J.Var -> J.Var -> StgAlt -> JSGen Config (AST Exp,AST Stm -> AST Stm)
+genAlt :: J.Var -> J.Var -> StgAlt -> JSGen Config (Exp, Stm -> Stm)
 genAlt scrut res (con, args, used, body) = do
   construct <- case con of
     -- undefined is intentional here - the first element is never touched.
@@ -324,73 +318,71 @@
   (_, body') <- isolate $ do
     continue $ foldr (.) id binds
     retEx <- genEx body
-    continue $ newVar True res retEx
+    continue $ newVar False res retEx
   return $ construct body'
   where
     bindVar v ix = newVar True v (index (varExp scrut) (litN ix))
 
 -- | Generate a result variable for the given scrutinee variable.
-genResultVar :: Var.Var -> JSGen Config J.Var
+genResultVar :: GHC.Var -> JSGen Config J.Var
 genResultVar v = do
-  cfg <- getCfg
-  (\mn -> toJSVar cfg mn v (Just "#result")) <$> getModName
+  v' <- genVar v >>= getActualName
+  case v' of
+    Foreign n ->
+      return $ Internal (Name (BS.append n "#result") Nothing) "" True
+    Internal (Name n mp) _ _ ->
+      return $ Internal (Name (BS.append n "#result") mp) "" True
 
 -- | Generate a new variable and add a dependency on it to the function
 --   currently being generated.
-genVar :: Var.Var -> JSGen Config J.Var
+genVar :: GHC.Var -> JSGen Config J.Var
 genVar v | hasRepresentation v = do
   case toBuiltin v of
     Just v' -> return v'
     _       -> do
       mymod <- getModName
-      cfg <- getCfg
-      v' <- return $ toJSVar cfg mymod v Nothing
+      v' <- getActualName $ toJSVar mymod v
       dependOn v'
       return v'
 genVar _ = do
   return $ foreignVar "_"
 
 -- | Extracts the name of a foreign var.
-foreignName :: ForeignCall -> String
-#if __GLASGOW_HASKELL__ >= 706
+foreignName :: ForeignCall -> BS.ByteString
 foreignName (CCall (CCallSpec (StaticTarget str _ _) _ _)) =
-  unpackFS str
-#else
-foreignName (CCall (CCallSpec (StaticTarget str _) _ _)) =
-  unpackFS str
-#endif
+  BS.fromString $ unpackFS str
 foreignName _ =
   error "Dynamic foreign calls not supported!"
 
-toJSVar :: Config -> String -> Var.Var -> Maybe String -> J.Var
-toJSVar c thisMod v msuffix =
+-- | Turn a 'GHC.Var' into a 'J.Var'. Falls back to a default module name,
+--   typically the name of the current module under compilation, if the given
+--   Var isn't qualified.
+toJSVar :: String -> GHC.Var -> J.Var
+toJSVar thisMod v =
   case idDetails v of
     FCallId fc -> foreignVar (foreignName fc)
     _
       | isLocalId v && not hasMod ->
-        internalVar (name (unique ++ suffix) (Just (myPkg, myMod))) ""
+        internalVar (name unique (Just (myPkg, myMod))) ""
       | isGlobalId v || hasMod ->
-        internalVar (name (extern ++ suffix) (Just (myPkg, myMod))) comment
+        internalVar (name extern (Just (myPkg, myMod))) comment
     _ ->
       error $ "Var is not local, global or external!"
   where
-    comment = myMod ++ "." ++ extern ++ suffix
-    suffix = case msuffix of
-               Just s -> s
-               _      -> ""
-    vname  = Var.varName v
+    comment = BS.concat [myMod, ".", extern]
+    vname  = GHC.varName v
     hasMod = case nameModule_maybe vname of
                Nothing -> False
                _       -> True
-    myMod =
-      maybe thisMod (moduleNameString . moduleName) (nameModule_maybe vname)
-    myPkg =
-      maybe "main" (showOutputable c . modulePackageId) (nameModule_maybe vname)
-    extern = occNameString $ nameOccName vname
-    unique = show $ nameUnique vname
+    myMod = BS.fromString $ maybe thisMod (moduleNameString . moduleName)
+                                          (nameModule_maybe vname)
+    myPkg = BS.fromString $ maybe "main" (pkgKeyString . modulePkgKey)
+                                         (nameModule_maybe vname)
+    extern = BS.fromString $ occNameString $ nameOccName vname
+    unique = BS.fromString $ show $ nameUnique vname
 
 -- | Generate an argument list. Any arguments of type State# a are filtered out.
-genArgs :: [StgArg] -> JSGen Config [AST Exp]
+genArgs :: [StgArg] -> JSGen Config [Exp]
 genArgs = mapM genArg . filter hasRep
   where
     hasRep (StgVarArg v) = hasRepresentation v
@@ -399,7 +391,7 @@
 -- | Filter out args without representation, along with their accompanying
 --   pair element, then generate code for the args.
 --   Se `genArgVarsPair` for more information.
-genArgsPair :: [(StgArg, a)] -> JSGen Config ([AST Exp], [a])
+genArgsPair :: [(StgArg, a)] -> JSGen Config ([Exp], [a])
 genArgsPair aps = do
     args' <- mapM genArg args
     return (args', xs)
@@ -410,7 +402,7 @@
 
 -- | Returns True if the given var actually has a representation.
 --   Currently, only values of type State# a are considered representationless.
-hasRepresentation :: Var.Var -> Bool
+hasRepresentation :: GHC.Var -> Bool
 hasRepresentation = typeHasRep . varType
 
 typeHasRep :: Type -> Bool
@@ -419,18 +411,13 @@
     Just (tc, _) -> tc /= statePrimTyCon
     _            -> True
 
-genArg :: StgArg -> JSGen Config (AST Exp)
+genArg :: StgArg -> JSGen Config Exp
 genArg (StgVarArg v)  = varExp <$> genVar v
 genArg (StgLitArg l)  = genLit l
-#if __GLASGOW_HASKELL__ < 706
-genArg (StgTypeArg t) = do
-  warn Normal "Generated StgTypeArg as 0!"
-  return (litN 0)
-#endif
 
 -- | Generate code for data constructor creation. Returns a pair of
 --   (constructor, field strictness annotations).
-genDataCon :: DataCon -> JSGen Config (AST Exp, [Bool])
+genDataCon :: DataCon -> JSGen Config (Exp, [Bool])
 genDataCon dc = do
   if isEnumerationDataCon dc
     then return (tagexp, [])
@@ -445,7 +432,7 @@
 --
 --   IMPORTANT: remember to update the RTS if any changes are made to the
 --              constructor tag values!
-genDataConTag :: DataCon -> AST Exp
+genDataConTag :: DataCon -> Exp
 genDataConTag d =
   case dataConNameModule d of
     ("True", "GHC.Types")  -> lit True
@@ -461,14 +448,10 @@
 
 
 -- | Generate literals.
-genLit :: L.Literal -> JSGen Config (AST Exp)
+genLit :: GHC.Literal -> JSGen Config Exp
 genLit l = do
   case l of
-#if __GLASGOW_HASKELL__ >= 707
-    MachStr s           -> return . lit $ B.toString s
-#else
-    MachStr s           -> return . lit $ unpackFS s
-#endif
+    MachStr s           -> return $ lit s
     MachInt n
       | n > 2147483647 ||
         n < -2147483648 -> do warn Verbose (constFail "Int" n)
@@ -485,7 +468,8 @@
     MachNullAddr        -> return $ litN 0
     MachInt64 n         -> return $ int64 n
     LitInteger n _      -> return $ lit n
-    MachLabel _ _ _     -> return $ lit ":(" -- Labels point to machine code - ignore!
+    -- Labels point to machine code - ignore!
+    MachLabel _ _ _     -> return $ litS ":("
   where
     constFail t n = t ++ " literal " ++ show n ++ " doesn't fit in 32 bits;"
                     ++ " truncating!"
@@ -501,7 +485,7 @@
         hi = n `shiftR` 32
 
 -- | Generate a function application.
-genApp :: Var.Var -> [StgArg] -> JSGen Config (AST Exp)
+genApp :: GHC.Var -> [StgArg] -> JSGen Config Exp
 genApp f xs = do
     f' <- varExp <$> genVar f
     xs' <- mapM genArg xs
@@ -515,9 +499,31 @@
 isEnumerationDataCon :: DataCon -> Bool
 isEnumerationDataCon = isEnumerationTyCon . dataConTyCon
 
+-- | Does this data constructor create a newtype-like value? That is, a value
+--   of a type with a single data constructor having a single argument?
+isNewtypeLikeCon :: DataCon -> Bool
+isNewtypeLikeCon c =
+  case tyConDataCons (dataConTyCon c) of
+    [_] -> case dataConRepArgTys c of
+      [t] -> isUnLiftedType t
+      _   -> False
+    _   -> False
+
+-- | Does this data constructor create a newtype-like value? That is, a value
+--   of a type with a single data constructor having a single unlifted
+--   argument?
+isNewtypeLike :: GHC.Var -> Bool
+isNewtypeLike v = maybe False id $ do
+  (tycon, _) <- splitTyConApp_maybe (varType v)
+  case tyConDataCons tycon of
+    [c] -> case dataConRepArgTys c of
+      [t] -> return (isUnLiftedType t)
+      _   -> return False
+    _   -> return False
+
 -- | Returns True if the given Var is an unboxed tuple with a single element
 --   after any represenationless elements are discarded.
-isUnaryUnboxedTuple :: Var.Var -> Bool
+isUnaryUnboxedTuple :: GHC.Var -> Bool
 isUnaryUnboxedTuple v = maybe False id $ do
     (_, args) <- splitTyConApp_maybe t
     case filter typeHasRep args of
@@ -527,7 +533,7 @@
     t = varType v
 
 -- | Is it safe to reorder values of the given type?
-reorderableType :: Var.Var -> Bool
+reorderableType :: GHC.Var -> Bool
 reorderableType v =
     case splitTyConApp_maybe t of
       Just (_, args) -> length (filter typeHasRep args) == length args
diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs
--- a/src/Haste/Config.hs
+++ b/src/Haste/Config.hs
@@ -15,9 +15,10 @@
 
 stdJSLibs :: [FilePath]
 stdJSLibs = map (jsDir </>)  [
-    "rts.js", "stdlib.js", "MVar.js", "StableName.js", "Integer.js", "Int64.js",
-    "md5.js", "array.js", "pointers.js", "cheap-unicode.js", "Canvas.js",
-    "Handle.js", "Weak.js"
+    "rts.js", "floatdecode.js", "stdlib.js", "jsstring.js", "endian.js",
+    "MVar.js", "StableName.js", "Integer.js", "Int64.js", "md5.js", "array.js",
+    "pointers.js", "cheap-unicode.js", "Canvas.js", "Handle.js", "Weak.js",
+    "Foreign.js"
   ]
 
 debugLib :: FilePath
@@ -52,68 +53,93 @@
   "window.onload = " <> mainSym <> ";"
 
 -- | Int op wrapper for strictly 32 bit (|0).
-strictly32Bits :: AST Exp -> AST Exp
+strictly32Bits :: Exp -> Exp
 strictly32Bits = flip (binOp BitOr) (litN 0)
 
 -- | Safe Int multiplication.
-safeMultiply :: AST Exp -> AST Exp -> AST Exp
+safeMultiply :: Exp -> Exp -> Exp
 safeMultiply a b = callForeign "imul" [a, b]
 
 -- | Fast but unsafe Int multiplication.
-fastMultiply :: AST Exp -> AST Exp -> AST Exp
+fastMultiply :: Exp -> Exp -> Exp
 fastMultiply = binOp Mul
 
 -- | Compiler configuration.
 data Config = Config {
     -- | Runtime files to dump into the JS blob.
     rtsLibs :: [FilePath],
+
     -- | Path to directory where system jsmods are located.
     libPaths :: [FilePath],
+
     -- | Write all jsmods to this path.
     targetLibPath :: FilePath,
+
     -- | A function that takes the main symbol as its input and outputs the
     --   code that starts the program.
     appStart :: AppStart,
+
     -- | Wrap the program in its own namespace?
     wrapProg :: Bool,
+
     -- | Options to the pretty printer.
     ppOpts :: PPOpts,
+
     -- | A function that takes the name of the a target as its input and
     --   outputs the name of the file its JS blob should be written to.
     outFile :: Config -> String -> String,
+
     -- | Link the program?
     performLink :: Bool,
+
     -- | A function to call on each Int arithmetic primop.
-    wrapIntMath :: AST Exp -> AST Exp,
+    wrapIntMath :: Exp -> Exp,
+
     -- | Operation to use for Int multiplication.
-    multiplyIntOp :: AST Exp -> AST Exp -> AST Exp,
+    multiplyIntOp :: Exp -> Exp -> Exp,
+
     -- | Be verbose about warnings, etc.?
     verbose :: Bool,
+
     -- | Perform optimizations over the whole program at link time?
     wholeProgramOpts :: Bool,
+
     -- | Allow the possibility that some tail recursion may not be optimized
     --   in order to gain slightly smaller code?
     sloppyTCE :: Bool,
+
     -- | Turn on run-time tracing of primops?
     tracePrimops :: Bool,
+
     -- | Run the entire thing through Google Closure when done?
     useGoogleClosure :: Maybe FilePath,
+
     -- | Extra flags for Google Closure to take?
     useGoogleClosureFlags :: [String],
+
     -- | Any external Javascript to link into the JS bundle.
     jsExternals :: [FilePath],
+
     -- | Produce a skeleton HTML file containing the program rather than a
     --   JS file.
     outputHTML :: Bool,
+
     -- | GHC DynFlags used for STG generation.
     --   Currently only used for printing StgSyn values.
     showOutputable :: forall a. Outputable a => a -> String,
+
     -- | Which module contains the program's main function?
     --   Defaults to Just ("main", "Main")
     mainMod :: Maybe (String, String),
+
     -- | Perform optimizations.
     --   Defaults to True.
-    optimize :: Bool
+    optimize :: Bool,
+
+    -- | Emit @"use strict";@ declaration. Does not affect minification, but
+    --   *does* affect any external JS.
+    --   Defaults to True.
+    useStrict :: Bool
   }
 
 -- | Default compiler configuration.
@@ -142,7 +168,8 @@
     outputHTML       = False,
     showOutputable   = const "No showOutputable defined in config!",
     mainMod          = Just ("main", "Main"),
-    optimize         = True
+    optimize         = True,
+    useStrict        = True
   }
 
 instance Default Config where
diff --git a/src/Haste/Environment.hs b/src/Haste/Environment.hs
--- a/src/Haste/Environment.hs
+++ b/src/Haste/Environment.hs
@@ -1,13 +1,14 @@
 {-# LANGUAGE CPP #-}
 -- | Paths, host bitness and other environmental information about Haste.
 module Haste.Environment (
-    hasteSysDir, jsmodSysDir, hasteInstSysDir, pkgSysDir, pkgSysLibDir, jsDir,
-    hasteUserDir, jsmodUserDir, hasteInstUserDir, pkgUserDir, pkgUserLibDir,
-    hostWordSize, ghcLibDir,
-    ghcBinary, ghcPkgBinary,
-    hasteBinary, hastePkgBinary, hasteInstHisBinary, hasteInstBinary,
+    hasteSysDir, jsmodSysDir, hasteCabalSysDir, pkgSysDir, pkgSysLibDir, jsDir,
+    hasteUserDir, jsmodUserDir, hasteCabalUserDir, pkgUserDir, pkgUserLibDir,
+    hasteGhcLibDir,
+    hostWordSize,
+    ghcPkgBinary, ghcBinary,
+    hasteBinary, hastePkgBinary, hasteInstHisBinary, hasteCabalBinary,
     hasteCopyPkgBinary, closureCompiler, portableHaste,
-    needsReboot, bootFile
+    hasteNeedsReboot, hasteCabalNeedsReboot, bootFile
   ) where
 import System.IO.Unsafe
 import Data.Bits
@@ -15,10 +16,27 @@
 import Control.Shell hiding (hClose)
 import Paths_haste_compiler
 import System.IO
-import System.Environment (getExecutablePath)
-import Haste.GHCPaths (ghcBinary, ghcPkgBinary, ghcLibDir)
+import Haste.GHCPaths (ghcPkgBinary, ghcBinary)
 import Haste.Version
+#if defined(PORTABLE)
+import System.Environment (getExecutablePath)
+#endif
 
+-- | Directory to search for GHC settings. Always equal to 'hasteSysDir'
+--   except on Windows where we rely on a working Haskell Platform for GCC and
+--   other needed tools.
+hasteGhcLibDir :: FilePath
+#ifdef mingw32_HOST_OS
+hasteGhcLibDir = unsafePerformIO $ do
+  eout <- shell $ run ghcBinary ["--print-libdir"] ""
+  case eout of
+    Right out -> return $ init out
+    _         -> error $ "This Haste build requires a working " ++
+                         "Haskell Platform install!"
+#else
+hasteGhcLibDir = hasteSysDir
+#endif
+
 #if defined(PORTABLE)
 -- | Was Haste built in portable mode or not?
 portableHaste :: Bool
@@ -68,33 +86,33 @@
 jsmodSysDir :: FilePath
 jsmodSysDir = hasteSysDir </> "jsmods"
 
--- | Base directory for haste-inst; system packages.
-hasteInstSysDir :: FilePath
-hasteInstSysDir = hasteSysDir </> "libraries"
+-- | Base directory for haste-cabal; system packages.
+hasteCabalSysDir :: FilePath
+hasteCabalSysDir = hasteSysDir </> "libraries"
 
 -- | Base directory for Haste's system libraries.
 pkgSysLibDir :: FilePath
-pkgSysLibDir = hasteInstSysDir </> "lib"
+pkgSysLibDir = hasteCabalSysDir </> "lib"
 
 -- | Directory housing package information.
 pkgSysDir :: FilePath
-pkgSysDir = hasteSysDir </> "packages"
+pkgSysDir = hasteSysDir </> "package.conf.d"
 
 -- | Directory where user .jsmod files are stored.
 jsmodUserDir :: FilePath
 jsmodUserDir = hasteUserDir </> "jsmods"
 
--- | Base directory for haste-inst.
-hasteInstUserDir :: FilePath
-hasteInstUserDir = hasteUserDir </> "libraries"
+-- | Base directory for haste-cabal.
+hasteCabalUserDir :: FilePath
+hasteCabalUserDir = hasteUserDir </> "libraries"
 
 -- | Directory containing library information.
 pkgUserLibDir :: FilePath
-pkgUserLibDir = hasteInstUserDir </> "lib"
+pkgUserLibDir = hasteCabalUserDir </> "lib"
 
 -- | Directory housing package information.
 pkgUserDir :: FilePath
-pkgUserDir = hasteUserDir </> "packages"
+pkgUserDir = hasteUserDir </> "package.conf.d"
 
 -- | Host word size in bits.
 hostWordSize :: Int
@@ -117,8 +135,8 @@
 hasteCopyPkgBinary = hasteBinDir </> "haste-copy-pkg"
 
 -- | Binary for haste-pkg.
-hasteInstBinary :: FilePath
-hasteInstBinary = hasteBinDir </> "haste-inst"
+hasteCabalBinary :: FilePath
+hasteCabalBinary = hasteBinDir </> "haste-cabal"
 
 -- | Binary for haste-install-his.
 hasteInstHisBinary :: FilePath
@@ -126,17 +144,25 @@
 
 -- | JAR for Closure compiler.
 closureCompiler :: FilePath
-closureCompiler = hasteBinDir </> "compiler.jar"
+closureCompiler = hasteSysDir </> "compiler.jar"
 
 -- | File indicating whether Haste is booted or not, and for which Haste+GHC
 --   version combo.
 bootFile :: FilePath
-bootFile = hasteSysDir </> "booted"
+bootFile = hasteUserDir </> "booted"
 
 -- | Returns which parts of Haste need rebooting. A change in the boot file
 --   format triggers a full reboot.
-needsReboot :: Bool
-needsReboot = unsafePerformIO $ do
+hasteNeedsReboot :: Bool
+#ifdef PORTABLE
+hasteNeedsReboot = False
+#else
+hasteNeedsReboot = hasteCabalNeedsReboot
+#endif
+
+-- | Does haste-cabal possibly needs rebooting?
+hasteCabalNeedsReboot :: Bool
+hasteCabalNeedsReboot = unsafePerformIO $ do
   exists <- shell $ isFile bootFile
   case exists of
     Right True -> do
diff --git a/src/Haste/Errors.hs b/src/Haste/Errors.hs
--- a/src/Haste/Errors.hs
+++ b/src/Haste/Errors.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- | Functions for warning about and causing runtime errors.
 module Haste.Errors (runtimeError, warn, WarnLevel(..)) where
 import System.IO.Unsafe
@@ -9,7 +10,7 @@
 data WarnLevel = Normal | Verbose deriving Eq
 
 -- | Produce a runtime error whenever this expression gets evaluated.
-runtimeError :: String -> AST Exp
+runtimeError :: String -> Exp
 runtimeError s = callForeign "die" [lit s]
 
 -- | Produce a warning message. This function is horrible and should be
diff --git a/src/Haste/GHCPaths.hs b/src/Haste/GHCPaths.hs
--- a/src/Haste/GHCPaths.hs
+++ b/src/Haste/GHCPaths.hs
@@ -1,6 +1,5 @@
 -- | Paths to GHC binaries and directories.
 module Haste.GHCPaths where
-import Control.Shell
 import System.IO.Unsafe
 import System.Directory (findExecutable)
 import Config (cProjectVersion)
@@ -27,9 +26,3 @@
     _       -> error $  "No appropriate ghc-pkg executable in search path!\n"
                      ++ "Are you sure you have GHC " ++ cProjectVersion
                      ++ " installed?"
-
--- | GHC library directory.
-ghcLibDir :: FilePath
-ghcLibDir = unsafePerformIO $ do
-  Right out <- shell $ run ghcBinary ["--print-libdir"] ""
-  return $ init out
diff --git a/src/Haste/Linker.hs b/src/Haste/Linker.hs
--- a/src/Haste/Linker.hs
+++ b/src/Haste/Linker.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses,
+             FlexibleContexts, OverloadedStrings #-}
 module Haste.Linker (link) where
 import Haste.Config
 import Haste.Module
@@ -6,9 +7,10 @@
 import qualified Data.Set as S
 import Control.Monad.State.Strict
 import Control.Monad.Trans.Either
-import Control.Applicative
 import Data.JSTarget
 import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString as BS
+import Data.ByteString.UTF8 (toString, fromString)
 import Data.ByteString.Builder
 import Data.Monoid
 import System.IO (hPutStrLn, stderr)
@@ -20,11 +22,12 @@
 mainSym = name "main" (Just ("main", ":Main"))
 
 -- | Link a program using the given config and input file name.
-link :: Config -> String -> FilePath -> IO ()
+link :: Config -> BS.ByteString -> FilePath -> IO ()
 link cfg pkgid target = do
-  let mainmod = case mainMod cfg of
-                 Just mm -> mm
-                 _       -> error "Haste.Linker.link called without main sym!"
+  let mainmod =
+        case mainMod cfg of
+         Just (m, p) -> (fromString m, fromString p)
+         _           -> error "Haste.Linker.link called without main sym!"
   ds <- getAllDefs cfg (targetLibPath cfg : libPaths cfg) mainmod pkgid mainSym
   let myDefs = if wholeProgramOpts cfg then topLevelInline ds else ds
       (progText, myMain') = prettyProg (ppOpts cfg) mainSym myDefs
@@ -40,13 +43,15 @@
     assembleProg True extlibs rtslibs progText callMain launchApp =
       stringUtf8 (unlines extlibs)
       <> stringUtf8 "var hasteMain = function() {"
+      <> (if useStrict cfg then stringUtf8 "\n\"use strict\";\n" else mempty)
       <> stringUtf8 (unlines rtslibs)
       <> progText
       <> callMain
       <> stringUtf8 "};\n"
       <> launchApp
     assembleProg _ extlibs rtslibs progText callMain launchApp =
-      stringUtf8 (unlines extlibs)
+      (if useStrict cfg then stringUtf8 "\"use strict\";\n" else mempty)
+      <> stringUtf8 (unlines extlibs)
       <> stringUtf8 (unlines rtslibs)
       <> progText
       <> stringUtf8 "\nvar hasteMain = function() {" <> callMain
@@ -60,26 +65,26 @@
 -- | Generate a sequence of all assignments needed to run Main.main.
 getAllDefs :: Config
            -> [FilePath]
-           -> (String, String)
-           -> String
+           -> (BS.ByteString, BS.ByteString)
+           -> BS.ByteString
            -> Name
-           -> IO (AST Stm)
+           -> IO Stm
 getAllDefs cfg libpaths mainmod pkgid mainsym =
   runDep cfg mainmod $ addDef libpaths pkgid mainsym
 
 data DepState = DepState {
-    mainmod     :: !(String, String),
-    defs        :: !(AST Stm -> AST Stm),
+    mainModule  :: !(BS.ByteString, BS.ByteString),
+    defs        :: !(Stm -> Stm),
     alreadySeen :: !(S.Set Name),
-    modules     :: !(M.Map String Module),
+    modules     :: !(M.Map BS.ByteString Module),
     infoLogger  :: String -> IO ()
   }
 
 type DepM a = EitherT Name (StateT DepState IO) a
 
-initState :: Config -> (String, String) -> DepState
+initState :: Config -> (BS.ByteString, BS.ByteString) -> DepState
 initState cfg m = DepState {
-    mainmod     = m,
+    mainModule  = m,
     defs        = id,
     alreadySeen = S.empty,
     modules     = M.empty,
@@ -93,14 +98,16 @@
   liftIO $ infoLogger st s
 
 -- | Run a dependency resolution computation.
-runDep :: Config -> (String, String) -> DepM a -> IO (AST Stm)
+runDep :: Show a => Config -> (BS.ByteString,BS.ByteString) -> DepM a -> IO Stm
 runDep cfg mainmod m = do
     res <- runStateT (runEitherT m) (initState cfg mainmod)
     case res of
       (Right _, st) ->
-        return $ defs st nullRet
-      (Left (Name f (Just (p, m))), _) -> do
-        error $ msg m f
+        return $ defs st stop
+      (Left (Name f (Just (_, modul))), _) -> do
+        error $ msg (toString modul) (toString f)
+      (r, _) -> do
+        error $ "Impossible result in runDep: " ++ show r
   where
     msg "Main" "main" =
       "Unable to locate a main function.\n" ++
@@ -109,8 +116,8 @@
       "for instance, `-main-is MyModule.myMain'.\n" ++
       "If your progam intentionally has no main function," ++
       " please use `--dont-link' to avoid this error."
-    msg m f =
-      "Unable to locate function `" ++ f ++ "' in module `" ++ m ++ "'!"
+    msg s f =
+      "Unable to locate function `" ++ f ++ "' in module `" ++ s ++ "'!"
 
 -- | Return the module the given variable resides in.
 getModuleOf :: [FilePath] -> Name -> DepM Module
@@ -120,7 +127,7 @@
     Just ""         -> return foreignModule
     Nothing         -> return foreignModule
     Just ":Main"    -> do
-      (p, m) <- mainmod `fmap` get
+      (p, m) <- mainModule `fmap` get
       getModuleOf libpaths (Name n (Just (p, m)))
     Just m          -> do
       mm <- getModule libpaths (maybe "main" id $ pkgOf v) m
@@ -130,18 +137,18 @@
 
 -- | Return the module at the given path, loading it into cache if it's not
 --   already there.
-getModule :: [FilePath] -> String -> String -> DepM (Maybe Module)
+getModule :: [FilePath] -> BS.ByteString -> BS.ByteString -> DepM (Maybe Module)
 getModule libpaths pkgid modname = do
     st <- get
     case M.lookup modname (modules st) of
       Just m -> do
         return $ Just m
       _ -> do
-        info $ "Linking " ++ modname
+        info $ "Linking " ++ toString modname
         go libpaths
   where
     go (libpath:lps) = do
-      mm <- liftIO $ readModule libpath pkgid modname
+      mm <- liftIO $ readModule libpath (toString pkgid) (toString modname)
       case mm of
         Just m -> do
           st <- get
@@ -154,7 +161,7 @@
 
 -- | Add a new definition and its dependencies. If the given identifier has
 --   already been added, it's just ignored.
-addDef :: [FilePath] -> String -> Name -> DepM ()
+addDef :: [FilePath] -> BS.ByteString -> Name -> DepM ()
 addDef libpaths pkgid v = do
   st <- get
   when (not $ v `S.member` alreadySeen st) $ do
diff --git a/src/Haste/Module.hs b/src/Haste/Module.hs
--- a/src/Haste/Module.hs
+++ b/src/Haste/Module.hs
@@ -6,6 +6,7 @@
 import Control.Applicative
 import Data.JSTarget
 import Data.Binary
+import qualified Data.ByteString.UTF8 as BS
 
 -- | The file extension to use for modules.
 jsmodExt :: Bool -> String
@@ -27,7 +28,8 @@
     mkdir True (takeDirectory path)
     liftIO $ B.writeFile path (encode m)
   where
-    path = moduleFilePath basepath pkgid modname boot
+    path =
+      moduleFilePath basepath (BS.toString pkgid) (BS.toString modname) boot
 
 -- | Read a module from file. If the module is not found at the specified path,
 --   libpath/path is tried instead. Returns Nothing is the module is not found
diff --git a/src/Haste/Monad.hs b/src/Haste/Monad.hs
--- a/src/Haste/Monad.hs
+++ b/src/Haste/Monad.hs
@@ -1,30 +1,42 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances,
+             MultiParamTypeClasses #-}
 module Haste.Monad (
     JSGen, genJS, dependOn, getModName, addLocal, getCfg, continue, isolate,
-    pushBind, popBind, getCurrentBinding, whenCfg
+    pushBind, popBind, getCurrentBinding, whenCfg, rename, getActualName
   ) where
-import Control.Monad.State
+import Control.Monad.State.Strict
 import Data.JSTarget as J hiding (modName)
 import qualified Data.Set as S
 import Control.Applicative
+import qualified Data.Map as M
 
 data GenState cfg = GenState {
-    deps         :: !(S.Set Name),
-    locals       :: !(S.Set Name),
-    continuation :: !(AST Stm -> AST Stm),
+    -- | Dependencies in current context.
+    deps         :: ![Name],
+    -- | Local variables in current context.
+    locals       :: ![Name],
+    -- | The current continuation. Code is generated by appending to this
+    --   continuation.
+    continuation :: !(Stm -> Stm),
+    -- | The stack of nested lambdas we've traversed.
     bindStack    :: ![Var],
+    -- | Name of the module being compiled.
     modName      :: !String,
-    config       :: !cfg
+    -- | Current compiler configuration.
+    config       :: !cfg,
+    -- | Mapping of variable renamings.
+    renames      :: !(M.Map Var Var)
   }
 
 initialState :: cfg -> GenState cfg
 initialState cfg = GenState {
-    deps         = S.empty,
-    locals       = S.empty,
+    deps         = [],
+    locals       = [],
     continuation = id,
     bindStack    = [],
     modName      = "",
-    config       = cfg
+    config       = cfg,
+    renames      = M.empty
   }
 
 newtype JSGen cfg a =
@@ -38,20 +50,25 @@
   addLocal :: a -> JSGen cfg ()
 
 instance Dependency J.Name where
+  {-# INLINE dependOn #-}
   dependOn v = JSGen $ do
     st <- get
-    put st {deps = S.insert v (deps st)}
+    put st {deps = v : deps st}
 
+  {-# INLINE addLocal #-}
   addLocal v = JSGen $ do
     st <- get
-    put st {locals = S.insert v (locals st)}
+    put st {locals = v : locals st}
 
 instance Dependency J.Var where
-  dependOn (Foreign _)    = return ()
-  dependOn (Internal n _) = dependOn n
-  addLocal (Foreign _)    = return ()
-  addLocal (Internal n _) = addLocal n
+  {-# INLINE dependOn #-}
+  dependOn (Foreign _)      = return ()
+  dependOn (Internal n _ _) = dependOn n
 
+  {-# INLINE addLocal #-}
+  addLocal (Foreign _)      = return ()
+  addLocal (Internal n _ _) = addLocal n
+
 instance Dependency a => Dependency [a] where
   dependOn = mapM_ dependOn
   addLocal = mapM_ addLocal
@@ -63,11 +80,11 @@
 genJS :: cfg         -- ^ Config to use for code generation.
       -> String      -- ^ Name of the module being compiled.
       -> JSGen cfg a -- ^ The code generation computation.
-      -> (a, S.Set J.Name, S.Set J.Name, AST Stm -> AST Stm)
+      -> (a, S.Set J.Name, S.Set J.Name, Stm -> Stm)
 genJS cfg myModName (JSGen gen) =
   case runState gen (initialState cfg) {modName = myModName} of
-    (a, GenState dependencies loc cont _ _ _) ->
-      (a, dependencies, loc, cont)
+    (a, GenState dependencies loc cont _ _ _ _) ->
+      (a, S.fromList dependencies, S.fromList loc, cont)
 
 getModName :: JSGen cfg String
 getModName = JSGen $ modName <$> get
@@ -86,20 +103,27 @@
 getCurrentBinding = JSGen $ fmap (head . bindStack) get
 
 -- | Add a new continuation onto the current one.
-continue :: (AST Stm -> AST Stm) -> JSGen cfg ()
+continue :: (Stm -> Stm) -> JSGen cfg ()
 continue cont = JSGen $ do
   st <- get
   put st {continuation = continuation st . cont}
 
 -- | Run a GenJS computation in isolation, returning its results rather than
 --   writing them to the output stream. Dependencies and locals are still
---   updated, however.
-isolate :: JSGen cfg a -> JSGen cfg (a, AST Stm -> AST Stm)
+--   updated, however, and any enclosing renames are still visible within
+--   the isolated computation.
+isolate :: JSGen cfg a -> JSGen cfg (a, Stm -> Stm)
 isolate gen = do
   myMod <- getModName
   cfg <- getCfg
   b <- getCurrentBinding
-  let (x, dep, loc, cont) = genJS cfg myMod (pushBind b >> gen)
+  rns <- renames <$> JSGen get
+  let (x, dep, loc, cont) = genJS cfg myMod $ do
+        pushBind b
+        JSGen $ do
+          st <- get
+          put st {renames = rns}
+        gen
   dependOn dep
   addLocal loc
   return (x, cont)
@@ -111,3 +135,20 @@
 whenCfg p act = do
   cfg <- getCfg
   when (p cfg) act
+
+-- | Run a computation with the given renaming added to its context.
+rename :: Var -> Var -> JSGen cfg a -> JSGen cfg a
+rename from to m = do
+  st <- JSGen get
+  JSGen $ put st {renames = M.insert from to $ renames st}
+  x <- m
+  st' <- JSGen get
+  JSGen $ put st' {renames = renames st}
+  return x
+
+-- | Get the actual name of a variable, recursing through multiple renamings
+--   if necessary.
+getActualName :: Var -> JSGen cfg Var
+getActualName v = do
+  rns <- renames <$> JSGen get
+  maybe (return v) getActualName $ M.lookup v rns
diff --git a/src/Haste/Opts.hs b/src/Haste/Opts.hs
--- a/src/Haste/Opts.hs
+++ b/src/Haste/Opts.hs
@@ -40,6 +40,11 @@
                                  performLink = False}) $
            "Install .jsmod files into the user's library. " ++
            "Implies --dont-link.",
+    Option "" ["no-use-strict"]
+           (NoArg $ \cfg -> cfg {useStrict = False}) $
+           "Do not emit '\"use strict\";' declaration. Does not affect " ++
+           "minifier behavior, but *does* affect any external JS included " ++
+           "with --with-js.",
     Option "" ["onexec"]
            (NoArg $ \cfg -> cfg {appStart = startCustom "onexec"}) $
            "Launch application immediately when the JS file is loaded. " ++
@@ -57,9 +62,8 @@
            "Enable all optimizations, safe and unsafe. Equivalent to " ++
            "--opt-all --opt-unsafe-ints",
     Option "" ["opt-minify"]
-           (OptArg updateClosureCfg "PATH") $
-           "Minify JS output using Google Closure compiler. " ++
-           "Optionally, use the Closure compiler located at PATH.",
+           (NoArg updateClosureCfg) $
+           "Minify JS output using Google Closure compiler.",
     Option "" ["opt-minify-flag"]
            (ReqArg updateClosureFlags "FLAG") $
            "Pass a flag to Closure. " ++
@@ -98,6 +102,11 @@
            (NoArg $ \cfg -> cfg {outputHTML = True}) $
            "Write the JS output to an HTML file together with a simple " ++
            "HTML skeleton.",
+    Option "" ["own-namespace"]
+           (NoArg $ \cfg -> cfg {wrapProg = True}) $
+           "Wrap the whole program in a closure to avoid polluting the " ++
+           "global namespace. Incurs a performance hit, and makes " ++
+           "minification slightly less effective.",
     Option "" ["start"]
            (ReqArg (\start cfg -> cfg {appStart = startCustom start})
                    "CODE") $
@@ -106,6 +115,11 @@
            "--start='$(\"foo\").onclick($HASTE_MAIN);' " ++
            "will use jQuery to launch the application whenever the element " ++
            "with the id \"foo\" is clicked.",
+    Option "" ["output-jsflow"]
+           (NoArg enableJSFlow) $
+           "Output code for use with the JSFlow interpreter. Note that " ++
+           "this may leave your code crippled, since JSFlow doesn't " ++
+           "all of Haste's needs.",
     Option "v" ["verbose"]
            (NoArg $ \cfg -> cfg {verbose = True}) $
            "Display even the most obnoxious warnings and messages.",
@@ -161,14 +175,11 @@
 
 -- | Enable all safe optimizations.
 optAllSafe :: Config -> Config
-optAllSafe = enableWholeProgramOpts . updateClosureCfg Nothing
+optAllSafe = enableWholeProgramOpts . updateClosureCfg
 
 -- | Set the path to the Closure compiler.jar to use.
-updateClosureCfg :: Maybe FilePath -> Config -> Config
-updateClosureCfg (Just fp) cfg =
-  cfg {useGoogleClosure = Just fp}
-updateClosureCfg _ cfg =
-  cfg {useGoogleClosure = Just closureCompiler}
+updateClosureCfg :: Config -> Config
+updateClosureCfg cfg = cfg {useGoogleClosure = Just closureCompiler}
 
 -- | Add flags for Google Closure to use
 updateClosureFlags :: String -> Config -> Config
@@ -178,6 +189,17 @@
 -- | Enable optimizations over the entire program.
 enableWholeProgramOpts :: Config -> Config
 enableWholeProgramOpts cfg = cfg {wholeProgramOpts = True}
+
+-- | Produce output for the JSFlow interpreter.
+enableJSFlow :: Config -> Config
+enableJSFlow cfg = cfg {
+    rtsLibs = [libfile |
+               libfile <- rtsLibs cfg,
+               not $ any (`isSuffixOf` libfile) jsflowIncompatible] ++
+              [jsDir </> "jsflow.js"]
+  }
+  where
+    jsflowIncompatible = ["floatdecode.js", "endian.js"]
 
 -- | Save some space and performance by using degenerate implementations of
 --   the Unicode functions.
diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs
--- a/src/Haste/PrimOps.hs
+++ b/src/Haste/PrimOps.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, OverloadedStrings #-}
 module Haste.PrimOps (genOp) where
 import Prelude hiding (LT, GT)
 import PrimOp
@@ -6,7 +6,7 @@
 import Haste.Config
 
 -- | Dummy State# RealWorld value for where one is needed.
-defState :: AST Exp
+defState :: Exp
 defState = litN 0
 
 -- | Generate primops.
@@ -15,7 +15,7 @@
 --   on the evaluation operation in the RTS being able to handle plain values
 --   as though they were thunks. If this were to change, all those ops MUST
 --   be changed to return thunks!
-genOp :: Config -> PrimOp -> [AST Exp] -> Either String (AST Exp)
+genOp :: Config -> PrimOp -> [Exp] -> Either String (Exp)
 genOp cfg op xs =
   case op of
     -- negations
@@ -59,9 +59,7 @@
     -- FIXME: this is correct but slow!
     IntMulMayOfloOp -> intMath $ Right $ multiplyIntOp cfg (xs !! 0) (xs !! 1)
     IntQuotOp ->       callF "quot"
-#if __GLASGOW_HASKELL__ >= 706
     IntQuotRemOp ->    callF "quotRemI"
-#endif
     IntRemOp ->        bOp Mod -- JS % operator is actually rem, not mod!
     IntAddCOp -> callF "addC"
     IntSubCOp -> callF "subC"
@@ -80,9 +78,7 @@
     WordSubOp ->  wordMath $ bOp Sub
     WordMulOp ->  wordMath $ callF "imul"
     WordQuotOp -> callF "quot"
-#if __GLASGOW_HASKELL__ >= 706
     WordQuotRemOp -> callF "quotRemI"
-#endif
     WordRemOp ->  bOp Mod
     AndOp ->      wordMath $ bOp BitAnd
     OrOp ->       wordMath $ bOp BitOr
@@ -154,8 +150,8 @@
     ReadArrayOp -> Right $ index arr ix
     WriteArrayOp -> Right $ assignEx (index arr ix) rhs
       where (_arr:_ix:rhs:_) = xs
-    SizeofArrayOp -> Right $ index (head xs) (lit "length")
-    SizeofMutableArrayOp -> Right $ index (head xs) (lit "length")
+    SizeofArrayOp -> Right $ index (head xs) (litS "length")
+    SizeofMutableArrayOp -> Right $ index (head xs) (litS "length")
     IndexArrayOp -> Right $ index arr ix
     UnsafeFreezeArrayOp -> Right $ head xs
     UnsafeThawArrayOp -> Right $ head xs
@@ -204,8 +200,8 @@
     WriteByteArrayOp_Float   -> writeArr xs "f32"
     WriteByteArrayOp_Double  -> writeArr xs "f64"
     
-    SizeofByteArrayOp        -> Right $ index (head xs) (lit "byteLength")
-    SizeofMutableByteArrayOp -> Right $ index (head xs) (lit "byteLength")
+    SizeofByteArrayOp        -> Right $ index (head xs) (litS "byteLength")
+    SizeofMutableByteArrayOp -> Right $ index (head xs) (litS "byteLength")
     NewAlignedPinnedByteArrayOp_Char -> Right $ callForeign "newByteArr" [xs!!0]
     UnsafeFreezeByteArrayOp  -> Right $ head xs
     ByteArrayContents_Char   -> Right $ head xs
@@ -267,7 +263,7 @@
         Right $ binOp Sub (litN 0) $ callForeign "addrLT" [a, b]
       where (a:b:_) = xs
     Addr2IntOp             ->
-        Right $ index x (lit "off")
+        Right $ index x (litS "off")
       where
         (x:_) = xs
 
@@ -324,23 +320,23 @@
   where
     (arr:ix:_) = xs
     
-    writeArr (a:i:rhs:_) elemtype =
-      Right $ assignEx (index (index (index a (lit "v")) (lit elemtype)) i) rhs
+    writeArr (a:i:rhs:_) etype =
+      Right $ assignEx (index (index (index a (litS "v")) (litS etype)) i) rhs
     writeArr _ _ =
       error "writeArray primop with too few arguments!"
 
     readArr (a:i:_) elemtype =
-      Right $ index (index (index a (lit "v")) (lit elemtype)) i
+      Right $ index (index (index a (litS "v")) (litS elemtype)) i
     readArr _ _ =
       error "writeArray primop with too few arguments!"
 
     writeOffAddr (addr:off:rhs:_) etype esize =
-      Right $ callForeign "writeOffAddr" [lit etype, litN esize, addr, off, rhs]
+      Right $ callForeign "writeOffAddr" [litS etype,litN esize,addr,off,rhs]
     writeOffAddr _ _ _ =
       error "writeOffAddr primop with too few arguments!"
     
     readOffAddr (addr:off:_) etype esize =
-      Right $ callForeign "readOffAddr" [lit etype, litN esize, addr, off]
+      Right $ callForeign "readOffAddr" [litS etype,litN esize,addr,off]
     readOffAddr _ _ _ =
       error "readOffAddr primop with too few arguments!"
 
diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs
--- a/src/Haste/Version.hs
+++ b/src/Haste/Version.hs
@@ -2,19 +2,17 @@
 module Haste.Version (
     BootVer (..),
     hasteVersion, intVersion, ghcVersion, bootVersion,
-    showBootVersion, parseBootVersion
+    showBootVersion, parseBootVersion,
+    showVersion
   ) where
-import System.IO.Unsafe
-import Control.Shell (shell, run)
 import Data.Version
 import Config (cProjectVersion)
-import Haste.GHCPaths (ghcBinary)
 import Text.ParserCombinators.ReadP
 import Data.Maybe (listToMaybe)
 
 -- | Current Haste version.
 hasteVersion :: Version
-hasteVersion = Version [0, 4, 4, 4] []
+hasteVersion = Version [0, 5, 0] []
 
 -- | Current Haste version as an Int. The format of this version number is
 --   MAJOR*10 000 + MINOR*100 + MICRO.
@@ -28,11 +26,7 @@
 ghcVersion =
     fst $ head $ filter (\(_,s) -> null s) parses
   where
-    parses = readP_to_S parseVersion . unsafePerformIO $ do
-      res <- shell $ run ghcBinary ["--numeric-version"] ""
-      case res of
-        Right ver -> return $ init ver -- remove trailing newline
-        _         -> return cProjectVersion
+    parses = readP_to_S parseVersion cProjectVersion
 
 -- | Haste + GHC version combo.
 bootVersion :: BootVer
diff --git a/src/Main.hs b/src/Main.hs
deleted file mode 100644
--- a/src/Main.hs
+++ /dev/null
@@ -1,267 +0,0 @@
-{-# LANGUAGE CPP #-}
-module Main (main) where
-import GHC
-import HscMain
-import Outputable (showPpr)
-import DynFlags
-import TidyPgm
-import CorePrep
-import CoreToStg
-import StgSyn (StgBinding)
-import HscTypes
-import GhcMonad
-import Module (packageIdString)
-import System.Environment (getArgs)
-import Control.Monad (when)
-import Haste
-import Haste.Args
-import Haste.Opts
-import Haste.Environment
-import Haste.Version
-import System.IO
-import System.Exit (exitFailure)
-import Data.Version
-import Data.List
-import qualified Control.Shell as Sh
-
-logStr :: Config -> String -> IO ()
-logStr cfg = when (verbose cfg) . hPutStrLn stderr
-
-rebootMsg :: String
-rebootMsg = "Haste needs to be rebooted; please run haste-boot"
-
-printInfo :: IO ()
-printInfo = do
-  ghc <- runGhc (Just ghcLibDir) getSessionDynFlags
-  putStrLn $ formatInfo $ compilerInfo ghc
-  where
-    formatInfo = ('[' :) . tail . unlines . (++ ["]"]) . map ((',' :) . show)
-
--- | Check for arguments concerning version info and the like, and act on them.
---   Return True if the compiler should run afterwards.
-preArgs :: [String] -> IO Bool
-preArgs args
-  | "--numeric-version" `elem` args =
-    putStrLn (showVersion ghcVersion) >> return False
-  | "--info" `elem` args =
-    printInfo >> return False
-  | "--print-libdir" `elem` args =
-    putStrLn ghcLibDir >> return False
-  | "--version" `elem` args =
-    putStrLn (showVersion hasteVersion) >> return False
-  | "--supported-extensions" `elem` args =
-    (putStrLn $ unlines $ supportedLanguagesAndExtensions) >> return False
-  | "--supported-languages" `elem` args =
-    (putStrLn $ unlines $ supportedLanguagesAndExtensions) >> return False
-  | otherwise =
-    return True
-
-main :: IO ()
-main = do
-    initUserPkgDB
-    args <- fmap (++ packageDBArgs) getArgs
-    runCompiler <- preArgs args
-    when (runCompiler) $ do
-      if allSupported args
-        then hasteMain args
-        else callVanillaGHC args
-  where
-#if __GLASGOW_HASKELL__ >= 706
-    packageDBArgs = ["-no-global-package-db",
-                     "-no-user-package-db",
-                     "-package-db " ++ pkgSysDir,
-                     "-package-db " ++ pkgUserDir ]
-#else
-    packageDBArgs = ["-no-user-package-conf",
-                     "-package-conf " ++ pkgSysDir]
-#endif
--- | Call vanilla GHC; used for boot files and the like.
-callVanillaGHC :: [String] -> IO ()
-callVanillaGHC args = do
-  _ <- Sh.shell $ Sh.run_ ghcBinary (filter noHasteArgs args) ""
-  return ()
-  where
-    noHasteArgs x =
-      x /= "--libinstall" &&
-      x /= "--unbooted"
-
-initUserPkgDB :: IO ()
-initUserPkgDB = do
-  _ <- Sh.shell $ do
-    pkgDirExists <- Sh.isDirectory pkgUserDir
-    when (not pkgDirExists) $ do
-      Sh.mkdir True pkgUserLibDir
-      Sh.runInteractive ghcPkgBinary ["init", pkgUserDir]
-  return ()
-
--- | Run the compiler if everything's satisfactorily booted, otherwise whine
---   and exit.
-hasteMain :: [String] -> IO ()
-hasteMain args
-  | not needsReboot =
-    compiler False ("-O2" : args)
-  | otherwise = do
-    if "--unbooted" `elem` args
-      then compiler True (filter (/= "--unbooted") ("-O2" : args))
-      else fail rebootMsg
-
--- | Determine whether all given args are handled by Haste, or if we need to
---   ship them off to vanilla GHC instead.
-allSupported :: [String] -> Bool
-allSupported args =
-  and args'
-  where
-    args' = [not $ any (`isSuffixOf` a) someoneElsesProblems | a <- args]
-    someoneElsesProblems = [".c", ".cmm"]
-
--- | The main compiler driver.
-compiler :: Bool -> [String] -> IO ()
-compiler unbooted cmdargs = do
-  let argRes = parseArgs (hasteOpts unbooted) helpHeader cmdargs
-      usedGhcMode = if "-c" `elem` cmdargs then OneShot else CompManager
-
-  case argRes of
-    -- We got --help as an argument - display help and exit.
-    Left help -> putStr help
-
-    -- We got a config and a set of arguments for GHC; let's compile!
-    Right (mkConfig, ghcargs) -> do
-      let config = mkConfig def
-
-      -- Parse static flags, but ignore profiling.
-      (ghcargs', _) <- parseStaticFlags [noLoc a | a <- ghcargs, a /= "-prof"]
-
-      runGhc (Just ghcLibDir) $ do
-        -- Handle dynamic GHC flags. Make sure __HASTE__ is #defined.
-        let hastever = "-D__HASTE__=" ++ show intVersion
-            args = hastever : map unLoc ghcargs'
-            justDie = const $ liftIO exitFailure
-        dynflags <- getSessionDynFlags
-        defaultCleanupHandler dynflags $ handleSourceError justDie $ do
-          (dynflags', files, _) <- parseDynamicFlags dynflags (map noLoc args)
-          _ <- setSessionDynFlags dynflags' {ghcLink = NoLink,
-                                             ghcMode = usedGhcMode}
-
-          -- Prepare and compile all needed targets.
-          let files' = map unLoc files
-              printErrorAndDie e = printException e >> liftIO exitFailure
-          deps <- handleSourceError printErrorAndDie $ do
-            ts <- mapM (flip guessTarget Nothing) files'
-            setTargets ts
-            _ <- load LoadAllTargets
-            depanal [] False
-          let cfg = fillLinkerConfig dynflags' config
-          mapM_ (compile cfg dynflags') deps
-
-          -- Link everything together into a .js file.
-          when (performLink cfg) $ liftIO $ do
-            flip mapM_ files' $ \file -> do
-              let outfile = outFile cfg cfg file
-              logStr cfg $ "Linking program " ++ outfile
-#if __GLASGOW_HASKELL__ >= 706
-              let pkgid = showPpr dynflags $ thisPackage dynflags'
-#else
-              let pkgid = showPpr $ thisPackage dynflags'
-#endif
-              link cfg pkgid file
-              case useGoogleClosure cfg of
-                Just clopath -> closurize cfg clopath outfile
-                _            -> return ()
-              when (outputHTML cfg) $ do
-                res <- Sh.shell $ Sh.withCustomTempFile "." $ \tmp h -> do
-                  prog <- Sh.file outfile
-                  Sh.hPutStrLn h (htmlSkeleton outfile prog)
-                  Sh.liftIO $ hClose h
-                  Sh.mv tmp outfile
-                case res of
-                  Right () -> return ()
-                  Left err -> error $ "Couldn't output HTML file: " ++ err
-
--- | Produce an HTML skeleton with an embedded JS program.
-htmlSkeleton :: FilePath -> String -> String
-htmlSkeleton filename prog = concat [
-  "<!DOCTYPE HTML>",
-  "<html><head>",
-  "<title>", filename , "</title>",
-  "<meta charset=\"UTF-8\">",
-  "<script type=\"text/javascript\">", prog, "</script>",
-  "</head><body></body></html>"]
-
--- | Do everything required to get a list of STG bindings out of a module.
-prepare :: (GhcMonad m) => DynFlags -> ModSummary -> m ([StgBinding], ModuleName)
-prepare dynflags theMod = do
-  env <- getSession
-  let name = moduleName $ ms_mod theMod
-  pgm <- parseModule theMod
-    >>= typecheckModule
-    >>= desugarModule
-    >>= liftIO . hscSimplify env . coreModule
-    >>= liftIO . tidyProgram env
-    >>= prepPgm env . fst
-#if __GLASGOW_HASKELL__ >= 707
-    >>= liftIO . coreToStg dynflags (ms_mod theMod)
-#else
-    >>= liftIO . coreToStg dynflags
-#endif
-  return (pgm, name)
-  where
-    prepPgm env tidy = liftIO $ do
-#if __GLASGOW_HASKELL__ >= 706
-      prepd <- corePrepPgm dynflags env (cg_binds tidy) (cg_tycons tidy)
-#else
-      prepd <- corePrepPgm dynflags (cg_binds tidy) (cg_tycons tidy)
-#endif
-      return prepd
-
--- | Run Google Closure on a file.
-closurize :: Config -> FilePath -> FilePath -> IO ()
-closurize cfg cloPath f = do
-  let arguments = useGoogleClosureFlags cfg
-  logStr cfg $ "Running the Google Closure compiler on " ++ f ++ "..."
-  let cloFile = f `Sh.addExtension` ".clo"
-  res <- Sh.shell $ do
-    str <- Sh.run "java"
-      (["-jar", cloPath,
-        "--compilation_level", "ADVANCED_OPTIMIZATIONS",
-        "--jscomp_off", "globalThis", f]
-       ++ arguments) ""
-    Sh.file cloFile str :: Sh.Shell ()
-    Sh.mv cloFile f
-  case res of
-    Left e  -> fail $ "Couldn't execute Google Closure compiler: " ++ e
-    Right _ -> return ()
-
--- | Compile a module into a .jsmod intermediate file.
-compile :: (GhcMonad m) => Config -> DynFlags -> ModSummary -> m ()
-compile cfg dynflags modSummary = do
-    let boot = case ms_hsc_src modSummary of
-                 HsBootFile -> True
-                 _          -> False
-    (pgm, name) <- prepare dynflags modSummary
-#if __GLASGOW_HASKELL__ >= 706
-    let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary
-        cfg' = cfg {showOutputable = showPpr dynflags}
-#else
-    let pkgid = showPpr $ modulePackageId $ ms_mod modSummary
-        cfg' = cfg {showOutputable = showPpr}
-#endif
-        theCode = generate cfg' pkgid name pgm
-    liftIO $ logStr cfg $ "Compiling " ++ myName boot ++ " into " ++ targetpath
-    liftIO $ writeModule targetpath theCode boot
-  where
-    myName False = moduleNameString $ moduleName $ ms_mod modSummary
-    myName True = myName False ++ " [boot]"
-    targetpath = targetLibPath cfg
-
--- | Fill in linkage info, such as whether to link at all and what the program
---   entry point is.
-fillLinkerConfig :: DynFlags -> Config -> Config
-fillLinkerConfig df cfg =
-    cfg {
-        mainMod = mainmod,
-        performLink = maybe False (const $ performLink cfg) mainmod
-      }
-  where
-    mainmod =
-      Just (packageIdString $ modulePackageId (mainModIs df),
-            moduleNameString $ moduleName (mainModIs df))
diff --git a/src/haste-boot.hs b/src/haste-boot.hs
--- a/src/haste-boot.hs
+++ b/src/haste-boot.hs
@@ -19,10 +19,10 @@
 import Haste.Args
 import System.Console.GetOpt
 
-#if __GLASGOW_HASKELL__ >= 708
-baseDir = "base-ghc-7.8"
+#if __GLASGOW_HASKELL__ >= 710
+libDir = "ghc-7.10"
 #else
-baseDir = "base-ghc-7.6"
+libDir = "ghc-7.8"
 #endif
 
 downloadFile :: String -> Shell BS.ByteString
@@ -45,18 +45,32 @@
     useLocalLibs          :: Bool,
     tracePrimops          :: Bool,
     forceBoot             :: Bool,
-    populateSetupExeCache :: Bool
+    populateSetupExeCache :: Bool,
+    initialPortableBoot   :: Bool
   }
 
 defCfg :: Cfg
+#ifdef PORTABLE
 defCfg = Cfg {
-    getLibs = True,
-    getClosure = True,
-    useLocalLibs = False,
-    tracePrimops = False,
-    forceBoot = False,
-    populateSetupExeCache = True
+    getLibs               = True,
+    getClosure            = False,
+    useLocalLibs          = False,
+    tracePrimops          = False,
+    forceBoot             = False,
+    populateSetupExeCache = True,
+    initialPortableBoot   = False
   }
+#else
+defCfg = Cfg {
+    getLibs               = True,
+    getClosure            = True,
+    useLocalLibs          = False,
+    tracePrimops          = False,
+    forceBoot             = False,
+    populateSetupExeCache = True,
+    initialPortableBoot   = False
+  }
+#endif
 
 devBoot :: Cfg -> Cfg
 devBoot cfg = cfg {
@@ -66,42 +80,61 @@
     populateSetupExeCache = False
   }
 
+setInitialPortableBoot :: Cfg -> Cfg
+setInitialPortableBoot cfg = cfg {
+    getLibs             = True,
+    useLocalLibs        = True,
+    forceBoot           = True,
+    getClosure          = True,
+    initialPortableBoot = True
+  }
+
 specs :: [OptDescr (Cfg -> Cfg)]
 specs = [
-    Option "" ["dev"]
+#ifndef PORTABLE
+      Option "" ["dev"]
            (NoArg devBoot) $
            "Boot Haste for development. Implies --force " ++
-           "--local --no-closure --no-populate-setup-exe-cache",
-    Option "" ["force"]
+           "--local --no-closure --no-populate-setup-exe-cache"
+    , Option "" ["force"]
+#else
+      Option "" ["force"]
+#endif
            (NoArg $ \cfg -> cfg {forceBoot = True}) $
-           "Re-boot Haste even if already properly booted.",
-    Option "" ["local"]
+           "Re-boot Haste even if already properly booted."
+    , Option "" ["initial"]
+           (NoArg setInitialPortableBoot) $
+           "Prepare boot files for binary distribution. Should only ever " ++
+           "be called by the release build scripts, never by users."
+#ifndef PORTABLE
+    , Option "" ["local"]
            (NoArg $ \cfg -> cfg {useLocalLibs = True}) $
            "Use libraries from source repository rather than " ++
            "downloading a matching set from the Internet. " ++
            "This is nearly always necessary when installing " ++
            "Haste from Git rather than from Hackage. " ++
            "When using --local, your current working directory " ++
-           "must be the root of the Haste source tree.",
-    Option "" ["no-closure"]
+           "must be the root of the Haste source tree."
+    , Option "" ["no-closure"]
            (NoArg $ \cfg -> cfg {getClosure = False}) $
            "Don't download Closure compiler. You won't be able " ++
            "to use --opt-minify, unless you manually " ++
-           "give hastec the path to compiler.jar.",
-    Option "" ["no-libs"]
+           "give hastec the path to compiler.jar."
+    , Option "" ["no-libs"]
            (NoArg $ \cfg -> cfg {getLibs = False}) $
            "Don't install any libraries. This is probably not " ++
-           "what you want.",
-    Option "" ["no-populate-setup-exe-cache"]
+           "what you want."
+    , Option "" ["no-populate-setup-exe-cache"]
            (NoArg $ \cfg -> cfg {populateSetupExeCache = False}) $
            "Don't populate Cabal's setup-exe-cache. Speeds up boot, " ++
            "but vill fail spectacularly unless your setup-exe-cache " ++
-           "is already populated.",
-    Option "" ["trace-primops"]
+           "is already populated."
+    , Option "" ["trace-primops"]
            (NoArg $ \cfg -> cfg {tracePrimops = True}) $
            "Build standard libs for tracing of primitive " ++
            "operations. Only use if you're debugging the code " ++
            "generator."
+#endif
   ]
 
 hdr :: String
@@ -113,7 +146,7 @@
   case parseArgs specs hdr args of
     Right (mkConfig, _) -> do
       let cfg = mkConfig defCfg
-      when (needsReboot || forceBoot cfg) $ do
+      when (hasteNeedsReboot || hasteCabalNeedsReboot || forceBoot cfg) $ do
         res <- shell $ if useLocalLibs cfg
                          then bootHaste cfg "."
                          else withTempDirectory "haste" $ bootHaste cfg
@@ -128,23 +161,30 @@
   removeBootFile <- isFile bootFile
   when removeBootFile $ rm bootFile
   when (getLibs cfg) $ do
+    when (not $ useLocalLibs cfg) $ do
+      fetchLibs tmpdir
     when (populateSetupExeCache cfg) $ do
       void $ run "cabal" ["update"] ""
       void $ run "cabal" ["install", "-j", "populate-setup-exe-cache"] ""
+      inDirectory "popcache" . void $ run "cabal" ["install", "-j"] ""
+      void $ run "ghc-pkg" ["unregister", "haste-populate-configure"] ""
       void $ run "ghc-pkg" ["unregister", "populate-setup-exe-cache"] ""
-    when (not $ useLocalLibs cfg) $ do
-      fetchLibs tmpdir
-    mapM_ clearDir [hasteInstUserDir, jsmodUserDir, pkgUserDir,
-                    hasteInstSysDir, jsmodSysDir, pkgSysDir]
-    buildLibs cfg
-    when (portableHaste) $ do
+
+    when (not portableHaste || initialPortableBoot cfg) $ do
+      mapM_ clearDir [hasteCabalUserDir, jsmodUserDir, pkgUserDir,
+                      hasteCabalSysDir, jsmodSysDir, pkgSysDir]
+      void $ run hastePkgBinary ["init", pkgSysDir] ""
+      buildLibs cfg
+
+    when (initialPortableBoot cfg) $ do
       mapM_ relocate ["array", "bytestring", "containers", "data-default",
                       "data-default-class", "data-default-instances-base",
                       "data-default-instances-containers",
                       "data-default-instances-dlist",
                       "data-default-instances-old-locale",
                       "deepseq", "dlist", "haste-lib", "integer-gmp",
-                      "monads-tf", "old-locale", "transformers"]
+                      "monads-tf", "old-locale", "transformers", "time"]
+
   when (getClosure cfg) $ do
     installClosure
   file bootFile (showBootVersion bootVersion)
@@ -184,40 +224,46 @@
     mkdir True $ pkgSysLibDir
     cpDir "include" hasteSysDir
     run_ hastePkgBinary ["update", "--global", "libraries" </> "rts.pkg"] ""
-    
+
     inDirectory "libraries" $ do
-      -- Install ghc-prim
-      inDirectory "ghc-prim" $ do
-        hasteInst ["configure", "--solver", "topdown"]
-        hasteInst $ ["build", "--install-jsmods"] ++ ghcOpts
-        run_ hasteInstHisBinary ["ghc-prim-0.3.0.0", "dist" </> "build"] ""
-        run_ hastePkgBinary ["update", "--global", "packageconfig"] ""
-      
-      -- Install integer-gmp; double install shouldn't be needed anymore.
-      run_ hasteCopyPkgBinary ["Cabal"] ""
-      inDirectory "integer-gmp" $ do
-        hasteInst ("install" : "--solver" : "topdown" : ghcOpts)
-      
-      -- Install base
-      inDirectory baseDir $ do
-        basever <- file "base.cabal" >>= return
-          . dropWhile (not . isDigit)
-          . head
-          . filter (not . null)
-          . filter (and . zipWith (==) "version")
-          . lines
-        hasteInst ["configure", "--solver", "topdown"]
-        hasteInst $ ["build", "--install-jsmods"] ++ ghcOpts
-        let base = "base-" ++ basever
-            pkgdb = "--package-db=dist" </> "package.conf.inplace"
-        run_ hasteInstHisBinary [base, "dist" </> "build"] ""
-        run_ hasteCopyPkgBinary [base, pkgdb] ""
-        forEachFile "include" $ \f -> cp f (hasteSysDir </> "include")
-      
-      -- Install array and haste-lib
-      forM_ ["array", "haste-lib"] $ \pkg -> do
-        inDirectory pkg $ hasteInst ("install" : ghcOpts)
+      inDirectory libDir $ do
+        -- Install ghc-prim
+        inDirectory "ghc-prim" $ do
+          hasteCabal ["configure", "--solver", "topdown"]
+          hasteCabal $ ["build", "--install-jsmods"] ++ ghcOpts
+          run_ hasteInstHisBinary ["ghc-prim-0.3.0.0", "dist" </> "build"] ""
+          run_ hastePkgBinary ["update", "--global", "packageconfig"] ""
 
+        -- Install integer-gmp; double install shouldn't be needed anymore.
+        run_ hasteCopyPkgBinary ["Cabal"] ""
+        inDirectory "integer-gmp" $ do
+          hasteCabal ("install" : "--solver" : "topdown" : ghcOpts)
+
+        -- Install base
+        inDirectory "base" $ do
+          basever <- file "base.cabal" >>= return
+            . dropWhile (not . isDigit)
+            . head
+            . filter (not . null)
+            . filter (and . zipWith (==) "version")
+            . lines
+          hasteCabal ["configure", "--solver", "topdown"]
+          hasteCabal $ ["build", "--install-jsmods"] ++ ghcOpts
+          let base = "base-" ++ basever
+              pkgdb = "--package-db=dist" </> "package.conf.inplace"
+          run_ hasteInstHisBinary [base, "dist" </> "build"] ""
+          run_ hasteCopyPkgBinary [base, pkgdb] ""
+          forEachFile "include" $ \f -> cp f (hasteSysDir </> "include")
+
+        -- Install array
+        inDirectory "array" $ hasteCabal ("install" : ghcOpts)
+
+      -- Install haste-lib
+      inDirectory "haste-lib" $ hasteCabal ("install" : ghcOpts)
+
+      -- Install time
+      inDirectory "time" $ hasteCabal ("install" : ghcOpts)
+
       -- Export monads-tf; it seems to be hidden by default
       run_ hastePkgBinary ["expose", "monads-tf"] ""
   where
@@ -225,8 +271,8 @@
         if tracePrimops cfg then ["--ghc-option=-debug"] else [],
         ["--ghc-option=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ show hostWordSize]
       ]
-    hasteInst args =
-      run_ hasteInstBinary ("--install-global" : "--unbooted" : args) ""
+    hasteCabal args =
+      run_ hasteCabalBinary ("--install-global" : "--unbooted" : args) ""
 
 relocate :: String -> Shell ()
 relocate pkg = run_ hastePkgBinary ["relocate", pkg] ""
diff --git a/src/haste-cabal.hs b/src/haste-cabal.hs
new file mode 100644
--- /dev/null
+++ b/src/haste-cabal.hs
@@ -0,0 +1,59 @@
+-- | haste-cabal - Haste wrapper for cabal.
+module Main where
+import System.Environment
+import System.Exit
+import Haste.Environment
+import Control.Shell
+import Control.Monad (when)
+import Data.List
+
+type Match = (String -> Bool, [String] -> [String])
+
+cabal :: [String] -> IO ()
+cabal args = do
+  res <- shell $ run_ "cabal" (hasteargs ++ args') ""
+  case res of
+    Left _ -> exitFailure
+    _      -> exitSuccess
+  where
+    args' = [arg | arg <- args, arg /= "--install-global", arg /= "--global"]
+    hasteargs
+      | "update" `elem` args =
+        []
+      | "build" `elem` args =
+        ["--with-ghc=" ++ hasteBinary]
+      | otherwise =
+        ["--with-compiler=" ++ hasteBinary,
+         "--with-hc-pkg=" ++ hastePkgBinary,
+         "--with-hsc2hs=hsc2hs",
+         "-fhaste-cabal"] ++
+        if "--install-global" `elem` args || "--global" `elem` args
+           then ["--prefix=" ++ hasteCabalSysDir,
+                 "--package-db=" ++ pkgSysDir]
+           else ["--prefix=" ++ hasteCabalUserDir,
+                 "--package-db=" ++ pkgSysDir,
+                 "--package-db=" ++ pkgUserDir]
+
+
+main :: IO ()
+main = do
+  as <- getArgs
+  when (hasteCabalNeedsReboot && not ("--unbooted" `elem` as)) $ do
+    putStrLn "WARNING: haste-cabal has not been properly booted."
+    putStrLn "If you experience problems installing packages, or simply want to"
+    putStrLn "get rid of this message, please run 'haste-boot'."
+
+  if "update" `elem` as
+    then do
+      cabal as
+    else do
+      as <- return $ if "--install-jsmods" `elem` as || not ("build" `elem` as)
+                       then libinstall : filter (/= "--install-jsmods") as
+                       else as
+      as <- return $ if "--unbooted" `elem` as
+                       then unbooted : filter (/= "--unbooted") as
+                       else as
+      cabal as
+  where
+    libinstall = "--ghc-option=--libinstall"
+    unbooted   = "--ghc-option=--unbooted"
diff --git a/src/haste-cat.hs b/src/haste-cat.hs
--- a/src/haste-cat.hs
+++ b/src/haste-cat.hs
@@ -1,3 +1,5 @@
+
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 import System.Environment
 import Haste.Module
@@ -6,7 +8,8 @@
 import Data.JSTarget.PP
 import Data.Maybe
 import qualified Data.Map as M
-import qualified Data.ByteString.Lazy.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import qualified Data.ByteString.Char8 as BS
 
 main = do
   as <- getArgs
@@ -23,11 +26,11 @@
   mapM_ printDef $ M.toList $ modDefs mod
 
 printDef (name, def) = do
-  putStrLn $ niceName name
-  BS.putStrLn $ pretty debugPPOpts def
+  BS.putStrLn $ niceName name
+  BSL.putStrLn $ pretty debugPPOpts def
   putStrLn ""
 
 niceName (Name n (Just (pkg, m))) =
-  pkg ++ ":" ++ m ++ "." ++ n
+  BS.concat [pkg, ":", m, ".", n]
 niceName (Name n _) =
   n
diff --git a/src/haste-copy-pkg.hs b/src/haste-copy-pkg.hs
--- a/src/haste-copy-pkg.hs
+++ b/src/haste-copy-pkg.hs
@@ -11,11 +11,7 @@
 main = do
   args <- getArgs
   let (dbs, pkgs) = partition ("--package-db=" `isPrefixOf`) args
-#if __GLASGOW_HASKELL__ < 706
-      pkgdbs = map (("--package-conf" ++) . drop 12) dbs
-#else
       pkgdbs = dbs
-#endif
   if null args
     then do
       putStrLn "Usage: haste-copy-pkg [--package-db=foo.conf] <packages>"
diff --git a/src/haste-inst.hs b/src/haste-inst.hs
deleted file mode 100644
--- a/src/haste-inst.hs
+++ /dev/null
@@ -1,47 +0,0 @@
--- | haste-inst - Haste wrapper for cabal.
-module Main where
-import System.Environment
-import System.Exit
-import Haste.Environment
-import Control.Shell
-import Data.List
-
-type Match = (String -> Bool, [String] -> [String])
-
-cabal :: [String] -> IO ()
-cabal args = do
-  res <- shell $ run_ "cabal" (hasteargs ++ args') ""
-  case res of
-    Left _ -> exitFailure
-    _      -> exitSuccess
-  where
-    args' = [arg | arg <- args, arg /= "--install-global", arg /= "--global"]
-    hasteargs 
-      | "build" `elem` args =
-        ["--with-ghc=" ++ hasteBinary]
-      | otherwise =
-        ["--with-compiler=" ++ hasteBinary,
-         "--with-hc-pkg=" ++ hastePkgBinary,
-         "--with-hsc2hs=hsc2hs",
-         "-fhaste-inst"] ++
-        if "--install-global" `elem` args || "--global" `elem` args
-           then ["--prefix=" ++ hasteInstSysDir,
-                 "--package-db=" ++ pkgSysDir]
-           else ["--prefix=" ++ hasteInstUserDir,
-                 "--package-db=" ++ pkgSysDir,
-                 "--package-db=" ++ pkgUserDir]
-
-
-main :: IO ()
-main = do
-  as <- getArgs
-  as <- return $ if "--install-jsmods" `elem` as || not ("build" `elem` as)
-                   then libinstall : filter (/= "--install-jsmods") as
-                   else as
-  as <- return $ if "--unbooted" `elem` as
-                   then unbooted : filter (/= "--unbooted") as
-                   else as
-  cabal as
-  where
-    libinstall = "--ghc-option=--libinstall"
-    unbooted   = "--ghc-option=--unbooted"
diff --git a/src/haste-pkg.hs b/src/haste-pkg.hs
deleted file mode 100644
--- a/src/haste-pkg.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-{-# LANGUAGE CPP #-}
--- | haste-pkg; wrapper for ghc-pkg.
-module Main where
-import Control.Monad
-import System.Environment (getArgs)
-import Haste.Environment
-import Control.Shell
-import System.Info (os)
-
-main = shell $ do
-  args <- liftIO getArgs
-  case args of
-    ["relocate", pkg] -> relocate packages pkg
-    _                 -> ghcPkg packages args
-  where
-#if __GLASGOW_HASKELL__ >= 706
-    packages = ["--global-package-db=" ++ pkgSysDir,
-                "--package-db=" ++ pkgSysDir,
-                "--package-db=" ++ pkgUserDir]
-#else
-    packages = ["--no-user-package-conf",
-                "--global-conf=" ++ pkgUserDir]
-#endif
-
-ghcPkg :: [String] -> [String] -> Shell ()
-ghcPkg packages args = do
-  pkgDirExists <- isDirectory pkgUserDir
-  when (not pkgDirExists) $ do
-    mkdir True pkgUserLibDir
-    runInteractive ghcPkgBinary ["init", pkgUserDir]
-  pkgDirExists <- isDirectory pkgSysDir
-  when (not pkgDirExists) $ do
-    mkdir True pkgSysLibDir
-    runInteractive ghcPkgBinary ["init", pkgSysDir]
-  runInteractive ghcPkgBinary (packages ++ args)
-
--- | Only global packages may be marked as relocatable!
---   May break horribly for general use, only reliable for Haste base packages.
-relocate :: [String] -> String -> Shell ()
-relocate packages pkg = do
-    pi <- run ghcPkgBinary (packages ++ ["describe", pkg]) ""
-    run_ ghcPkgBinary (packages++["update","-","--force","--global"]) (reloc pi)
-  where
-    reloc = unlines . map fixPath . lines
-
-    fixPath s
-      | isKey "library-dirs: " s       = prefix s "library-dirs" importDir
-      | isKey "import-dirs: " s        = prefix s "import-dirs" importDir
-      | isKey "haddock-interfaces: " s = prefix s "haddock-interfaces" importDir
-      | isKey "haddock-html: " s       = prefix s "haddock-html" importDir
-      | isKey "include-dirs: " s       = "include-dirs: " ++ includeDir
-      | otherwise                      = s
-
-    prefix s pfx path = pfx ++ ": " ++ path </> stripPrefix s
-
-    stripPrefix s
-      | os == "darwin" =
-        case take 3 $ reverse $ splitPath s of
-          [third, second, first] -> first </> second </> third
-      | otherwise =
-        case take 2 $ reverse $ splitPath s of
-          [second, first] -> first </> second
-
-    isKey _ "" =
-      False
-    isKey key str =
-      and $ zipWith (==) key str
-
-    importDir
-      | os == "linux"  = "${pkgroot}" </> "libraries" </> "lib"
-      | otherwise      = "${pkgroot}" </> "libraries"
-    includeDir = "${pkgroot}" </> "include"
diff --git a/src/hastec.hs b/src/hastec.hs
new file mode 100644
--- /dev/null
+++ b/src/hastec.hs
@@ -0,0 +1,203 @@
+{-# LANGUAGE CPP #-}
+-- | Haste's main compiler driver.
+module Main where
+import Language.Haskell.GHC.Simple
+import GHC
+import Outputable (showPpr)
+
+import System.Environment (getArgs)
+import System.Exit
+import Data.List
+import System.IO.Unsafe
+import System.IO
+import Control.Monad
+import qualified Control.Shell as Sh
+import qualified Data.ByteString.UTF8 as BS
+
+import Haste.Opts
+import Haste.Args
+import Haste.Config
+import Haste.Environment
+import Haste.Version
+import Haste.Module
+import Haste.CodeGen
+import Haste.Linker
+
+logStr :: Config -> String -> IO ()
+logStr cfg = when (verbose cfg) . hPutStrLn stderr
+
+main :: IO ()
+main = do
+    initUserPkgDB
+    as <- getArgs
+    let args = "-O2":concat [as,packageDBArgs,["-D__HASTE__="++show intVersion]]
+    case parseHasteFlags args of
+      Left act             -> act
+      Right (fs, mkConfig) -> do
+        let ghcconfig = mkGhcCfg fs args
+        (dfs, _) <- getDynFlagsForConfig ghcconfig
+        let cfg = mkLinkerCfg dfs . setShowOutputable dfs $ mkConfig def
+        res <- compileFold ghcconfig (compJS cfg) [] []
+        case res of
+          Failure _ _         -> do
+            exitFailure
+          Success targets _ _ -> do
+            when (performLink cfg) $ do
+              mapM_ (uncurry $ linkAndMinify cfg) targets
+  where
+    compJS cfg targets m = do
+      compJSMod cfg m
+      let infile = maybe (modInterfaceFile m) id (modSourceFile m)
+      if modIsTarget m
+        then return $ (modPackageKey m, infile) : targets
+        else return targets
+
+    mkGhcCfg fs args = defaultConfig {
+        cfgGhcFlags = fs,
+        cfgGhcLibDir = Just hasteGhcLibDir,
+        cfgUseTargetsFromFlags = True,
+        cfgUseGhcErrorLogger = True,
+        cfgUpdateDynFlags = \dfs -> dfs {
+            ghcLink = NoLink,
+            ghcMode = if "-c" `elem` args
+                        then OneShot
+                        else CompManager
+          }
+
+      }
+    mkLinkerCfg dfs cfg = cfg {
+        mainMod = Just (pkgKeyString $ modulePkgKey (mainModIs dfs),
+                        moduleNameString $ moduleName (mainModIs dfs))
+      }
+    setShowOutputable dfs cfg = cfg {showOutputable = showPpr dfs}
+    -- TODO: this breaks sandboxes and must be fixed
+    packageDBArgs = ["-no-global-package-db",
+                     "-no-user-package-db",
+                     "-package-db " ++ pkgSysDir,
+                     "-package-db " ++ pkgUserDir ]
+
+-- | Compile an STG module into a JS module and write it to its appropriate
+--   location according to the given config.
+compJSMod :: Config -> StgModule -> IO ()
+compJSMod cfg stg = do
+    logStr cfg $ "Compiling " ++ myName ++ " into " ++ targetpath
+    writeModule targetpath (generate cfg stg) boot
+  where
+    boot = modSourceIsHsBoot stg
+    myName = modName stg ++ if boot then " [boot]" else ""
+    targetpath = targetLibPath cfg
+
+-- | Link a program starting from the 'mainMod' symbol of the given 'Config'.
+--   Minify the result if indicated by the config.
+linkAndMinify :: Config -> String -> FilePath -> IO ()
+linkAndMinify cfg pkgkey infile = do
+    logStr cfg $ "Linking target " ++ outfile
+    link cfg (BS.fromString pkgkey) infile
+    case useGoogleClosure cfg of
+      Just clopath -> closurize cfg clopath outfile
+      _            -> return ()
+    when (outputHTML cfg) $ do
+      res <- Sh.shell $ Sh.withCustomTempFile "." $ \tmp h -> do
+        prog <- Sh.file outfile
+        Sh.hPutStrLn h (htmlSkeleton outfile prog)
+        Sh.liftIO $ hClose h
+        Sh.mv tmp outfile
+      case res of
+        Right () -> return ()
+        Left err -> error $ "Couldn't output HTML file: " ++ err
+  where
+    outfile = outFile cfg cfg infile
+
+-- | Produce an HTML skeleton with an embedded JS program.
+htmlSkeleton :: FilePath -> String -> String
+htmlSkeleton filename prog = concat [
+  "<!DOCTYPE HTML>",
+  "<html><head>",
+  "<title>", filename , "</title>",
+  "<meta charset=\"UTF-8\">",
+  "<script type=\"text/javascript\">", prog, "</script>",
+  "</head><body></body></html>"]
+
+-- | Run Google Closure on a file.
+closurize :: Config -> FilePath -> FilePath -> IO ()
+closurize cfg cloPath f = do
+  let arguments = useGoogleClosureFlags cfg
+  logStr cfg $ "Minifying " ++ f ++ "..."
+  let cloFile = f `Sh.addExtension` ".clo"
+  res <- Sh.shell $ do
+    str <- Sh.run "java"
+      (["-jar", cloPath,
+        "--compilation_level", "ADVANCED_OPTIMIZATIONS",
+        "--jscomp_off", "globalThis", f]
+       ++ arguments) ""
+    Sh.file cloFile str :: Sh.Shell ()
+    Sh.mv cloFile f
+  case res of
+    Left e  -> fail $ "Couldn't execute Google Closure compiler: " ++ e
+    Right _ -> return ()
+
+-- | Call vanilla GHC; used for C files and the like.
+callVanillaGHC :: [String] -> IO ()
+callVanillaGHC args = do
+    _ <- Sh.shell $ Sh.run_ ghcBinary ghcArgs ""
+    return ()
+  where
+    Right (_, ghcArgs) = parseArgs (hasteOpts False) "" args
+
+-- | Initialize the Haste package database, unless it already exists.
+initUserPkgDB :: IO ()
+initUserPkgDB = do
+  _ <- Sh.shell $ do
+    pkgDirExists <- Sh.isDirectory pkgUserDir
+    when (not pkgDirExists) $ do
+      Sh.mkdir True pkgUserLibDir
+      Sh.runInteractive hastePkgBinary ["init", pkgUserDir]
+  return ()
+
+type Message = String
+data BootMode = Booted | Unbooted deriving (Show, Eq)
+data Compiler = Haste BootMode | GHC deriving (Show, Eq)
+data RunMode = Run !Compiler | DontRun !Message deriving (Show, Eq)
+
+rebootMsg :: Message
+rebootMsg = "Haste needs to be rebooted; please run haste-boot"
+
+-- | How should we run the compiler for this command line?
+runMode :: [String] -> RunMode
+runMode args
+  | "--help" `elem` args                 = Run (Haste Booted)
+  | "--info" `elem` args                 = DontRun ghcInfo
+  | "--print-libdir" `elem` args         = DontRun hasteGhcLibDir
+  | "--version" `elem` args              = DontRun $ showVersion hasteVersion
+  | "--numeric-version" `elem` args      = DontRun $ showVersion ghcVersion
+  | "--supported-extensions" `elem` args = DontRun exts
+  | "--supported-languages" `elem` args  = DontRun exts
+  | "--unbooted" `elem` args             = Run (chooseCompilerFor args Unbooted)
+  | hasteNeedsReboot                     = DontRun rebootMsg
+  | otherwise                            = Run (chooseCompilerFor args Booted)
+  where
+    exts = unlines supportedLanguagesAndExtensions
+    ghcInfo = unsafePerformIO $ do
+      dfs <- runGhc (Just hasteGhcLibDir) $ getSessionDynFlags
+      return $ formatInfo $ compilerInfo dfs
+    formatInfo = ('[' :) . tail . unlines . (++ ["]"]) . map ((',' :) . show)
+
+-- | Parse Haste and static GHC flags, returning either an action to be taken
+--   before promptly exiting, or a Haste config and a list of flags for GHC.
+parseHasteFlags :: [String] -> Either (IO ()) ([String], Config -> Config)
+parseHasteFlags args = do
+  case runMode args of
+   DontRun msg    -> Left $ putStrLn msg
+   Run GHC        -> Left $ callVanillaGHC args
+   Run (Haste bm) -> do
+     case parseArgs (hasteOpts $ bm == Unbooted) helpHeader args of
+       Left msg          -> Left $ putStrLn msg
+       Right (cfg, rest) -> Right (filter (/= "-prof") rest, cfg)
+
+-- | Use Haste or GHC for this command line?
+chooseCompilerFor :: [String] -> BootMode -> Compiler
+chooseCompilerFor args bm
+  | all hasteOK args  = Haste bm
+  | otherwise         = GHC
+  where
+    hasteOK f = not $ any (`isSuffixOf` f) [".c",".cmm",".cc"]
diff --git a/utils/haste-pkg/CRT_noglob.c b/utils/haste-pkg/CRT_noglob.c
new file mode 100644
--- /dev/null
+++ b/utils/haste-pkg/CRT_noglob.c
@@ -0,0 +1,4 @@
+// Turns off globbing for MingW, this is the same as that
+// CRT_noglob.o, but avoids having to locate CRT_nogob.o in the
+// filesystem.
+unsigned long _CRT_glob = 0;
diff --git a/utils/haste-pkg/haste-pkg.hs b/utils/haste-pkg/haste-pkg.hs
new file mode 100644
--- /dev/null
+++ b/utils/haste-pkg/haste-pkg.hs
@@ -0,0 +1,1831 @@
+{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2004-2009.
+--
+-- Package management tool
+--
+-----------------------------------------------------------------------------
+
+module Main (main) where
+
+import Distribution.InstalledPackageInfo.Binary()
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.ModuleName hiding (main)
+import Distribution.InstalledPackageInfo
+import Distribution.Compat.ReadP
+import Distribution.ParseUtils
+import Distribution.Package hiding (depends)
+import Distribution.Text
+import Distribution.Version
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
+import System.Process
+import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
+                          getModificationTime )
+import Text.Printf
+
+import Prelude
+
+import System.Console.GetOpt
+import qualified Control.Exception as Exception
+import Data.Maybe
+
+import Data.Char ( isSpace, toLower )
+import Data.Ord (comparing)
+import Control.Applicative (Applicative(..))
+import Control.Monad
+import System.Directory ( doesDirectoryExist, getDirectoryContents,
+                          doesFileExist, renameFile, removeFile,
+                          getCurrentDirectory )
+import System.Exit ( exitWith, ExitCode(..) )
+import System.Environment ( getArgs, getProgName, getEnv )
+import System.IO
+import System.IO.Error
+import Data.List
+import Control.Concurrent
+
+import qualified Data.ByteString.Lazy as B
+import qualified Data.Binary as Bin
+import qualified Data.Binary.Get as Bin
+
+-- Haste-specific
+import Haste.Environment
+import Haste.Version
+import System.Info (os)
+import qualified Control.Shell as Sh
+
+#if defined(mingw32_HOST_OS)
+-- mingw32 needs these for getExecDir
+import Foreign
+import Foreign.C
+#endif
+
+#ifdef mingw32_HOST_OS
+import GHC.ConsoleHandler
+#else
+import System.Posix hiding (fdToHandle)
+#endif
+
+#if defined(GLOB)
+import qualified System.Info(os)
+#endif
+
+#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)
+import System.Console.Terminfo as Terminfo
+#endif
+
+#ifdef mingw32_HOST_OS
+# if defined(i386_HOST_ARCH)
+#  define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+#  define WINDOWS_CCONV ccall
+# else
+#  error Unknown mingw32 arch
+# endif
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Entry point
+
+main :: IO ()
+main = do
+  args <- getArgs
+
+  case args of
+    ["relocate", pkg] -> do
+      Sh.shell (relocate packages pkg) >> exitWith ExitSuccess
+    _ ->
+      return ()
+
+  case getOpt Permute (flags ++ deprecFlags) args of
+        (cli,_,[]) | FlagHelp `elem` cli -> do
+           prog <- getProgramName
+           bye (usageInfo (usageHeader prog) flags)
+        (cli,_,[]) | FlagVersion `elem` cli ->
+           bye ourCopyright
+        (cli,nonopts,[]) ->
+           case getVerbosity Normal cli of
+           Right v -> runit v cli nonopts
+           Left err -> die err
+        (_,_,errors) -> do
+           prog <- getProgramName
+           die (concat errors ++ shortUsage prog)
+  where
+    packages = ["--global-package-db=" ++ pkgSysDir,
+                "--package-db=" ++ pkgSysDir,
+                "--package-db=" ++ pkgUserDir]
+
+-- -----------------------------------------------------------------------------
+-- Command-line syntax
+
+data Flag
+  = FlagUser
+  | FlagGlobal
+  | FlagHelp
+  | FlagVersion
+  | FlagConfig FilePath
+  | FlagGlobalConfig FilePath
+  | FlagForce
+  | FlagForceFiles
+  | FlagAutoGHCiLibs
+  | FlagExpandEnvVars
+  | FlagExpandPkgroot
+  | FlagNoExpandPkgroot
+  | FlagSimpleOutput
+  | FlagNamesOnly
+  | FlagIgnoreCase
+  | FlagNoUserDb
+  | FlagVerbosity (Maybe String)
+  deriving Eq
+
+flags :: [OptDescr Flag]
+flags = [
+  Option [] ["user"] (NoArg FlagUser)
+        "use the current user's package database",
+  Option [] ["global"] (NoArg FlagGlobal)
+        "use the global package database",
+  Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR")
+        "use the specified package database",
+  Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR")
+        "use the specified package database (DEPRECATED)",
+  Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR")
+        "location of the global package database",
+  Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
+        "never read the user package database",
+  Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
+        "never read the user package database (DEPRECATED)",
+  Option [] ["force"] (NoArg FlagForce)
+         "ignore missing dependencies, directories, and libraries",
+  Option [] ["force-files"] (NoArg FlagForceFiles)
+         "ignore missing directories and libraries only",
+  Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
+        "automatically build libs for GHCi (with register)",
+  Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
+        "expand environment variables (${name}-style) in input package descriptions",
+  Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
+        "expand ${pkgroot}-relative paths to absolute in output package descriptions",
+  Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
+        "preserve ${pkgroot}-relative paths in output package descriptions",
+  Option ['?'] ["help"] (NoArg FlagHelp)
+        "display this help and exit",
+  Option ['V'] ["version"] (NoArg FlagVersion)
+        "output version information and exit",
+  Option [] ["simple-output"] (NoArg FlagSimpleOutput)
+        "print output in easy-to-parse format for some commands",
+  Option [] ["names-only"] (NoArg FlagNamesOnly)
+        "only print package names, not versions; can only be used with list --simple-output",
+  Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
+        "ignore case for substring matching",
+  Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
+        "verbosity level (0-2, default 1)"
+  ]
+
+data Verbosity = Silent | Normal | Verbose
+    deriving (Show, Eq, Ord)
+
+getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
+getVerbosity v [] = Right v
+getVerbosity _ (FlagVerbosity Nothing    : fs) = getVerbosity Verbose fs
+getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent  fs
+getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal  fs
+getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
+getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
+getVerbosity v (_ : fs) = getVerbosity v fs
+
+deprecFlags :: [OptDescr Flag]
+deprecFlags = [
+        -- put deprecated flags here
+  ]
+
+ourCopyright :: String
+ourCopyright = "Haste package manager version " ++ showVersion ghcVersion ++ "\n"
+
+shortUsage :: String -> String
+shortUsage prog = "For usage information see '" ++ prog ++ " --help'."
+
+usageHeader :: String -> String
+usageHeader prog = substProg prog $
+  "Usage:\n" ++
+  "  $p init {path}\n" ++
+  "    Create and initialise a package database at the location {path}.\n" ++
+  "    Packages can be registered in the new database using the register\n" ++
+  "    command with --package-db={path}.  To use the new database with GHC,\n" ++
+  "    use GHC's -package-db flag.\n" ++
+  "\n" ++
+  "  $p register {filename | -}\n" ++
+  "    Register the package using the specified installed package\n" ++
+  "    description. The syntax for the latter is given in the $p\n" ++
+  "    documentation.  The input file should be encoded in UTF-8.\n" ++
+  "\n" ++
+  "  $p update {filename | -}\n" ++
+  "    Register the package, overwriting any other package with the\n" ++
+  "    same name. The input file should be encoded in UTF-8.\n" ++
+  "\n" ++
+  "  $p unregister {pkg-id}\n" ++
+  "    Unregister the specified package.\n" ++
+  "\n" ++
+  "  $p expose {pkg-id}\n" ++
+  "    Expose the specified package.\n" ++
+  "\n" ++
+  "  $p hide {pkg-id}\n" ++
+  "    Hide the specified package.\n" ++
+  "\n" ++
+  "  $p trust {pkg-id}\n" ++
+  "    Trust the specified package.\n" ++
+  "\n" ++
+  "  $p distrust {pkg-id}\n" ++
+  "    Distrust the specified package.\n" ++
+  "\n" ++
+  "  $p list [pkg]\n" ++
+  "    List registered packages in the global database, and also the\n" ++
+  "    user database if --user is given. If a package name is given\n" ++
+  "    all the registered versions will be listed in ascending order.\n" ++
+  "    Accepts the --simple-output flag.\n" ++
+  "\n" ++
+  "  $p dot\n" ++
+  "    Generate a graph of the package dependencies in a form suitable\n" ++
+  "    for input for the graphviz tools.  For example, to generate a PDF" ++
+  "    of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
+  "\n" ++
+  "  $p find-module {module}\n" ++
+  "    List registered packages exposing module {module} in the global\n" ++
+  "    database, and also the user database if --user is given.\n" ++
+  "    All the registered versions will be listed in ascending order.\n" ++
+  "    Accepts the --simple-output flag.\n" ++
+  "\n" ++
+  "  $p latest {pkg-id}\n" ++
+  "    Prints the highest registered version of a package.\n" ++
+  "\n" ++
+  "  $p check\n" ++
+  "    Check the consistency of package dependencies and list broken packages.\n" ++
+  "    Accepts the --simple-output flag.\n" ++
+  "\n" ++
+  "  $p describe {pkg}\n" ++
+  "    Give the registered description for the specified package. The\n" ++
+  "    description is returned in precisely the syntax required by $p\n" ++
+  "    register.\n" ++
+  "\n" ++
+  "  $p field {pkg} {field}\n" ++
+  "    Extract the specified field of the package description for the\n" ++
+  "    specified package. Accepts comma-separated multiple fields.\n" ++
+  "\n" ++
+  "  $p dump\n" ++
+  "    Dump the registered description for every package.  This is like\n" ++
+  "    \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
+  "    by tools that parse the results, rather than humans.  The output is\n" ++
+  "    always encoded in UTF-8, regardless of the current locale.\n" ++
+  "\n" ++
+  "  $p recache\n" ++
+  "    Regenerate the package database cache.  This command should only be\n" ++
+  "    necessary if you added a package to the database by dropping a file\n" ++
+  "    into the database directory manually.  By default, the global DB\n" ++
+  "    is recached; to recache a different DB use --user or --package-db\n" ++
+  "    as appropriate.\n" ++
+  "\n" ++
+  " Substring matching is supported for {module} in find-module and\n" ++
+  " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
+  " open substring ends (prefix*, *suffix, *infix*).\n" ++
+  "\n" ++
+  "  When asked to modify a database (register, unregister, update,\n"++
+  "  hide, expose, and also check), ghc-pkg modifies the global database by\n"++
+  "  default.  Specifying --user causes it to act on the user database,\n"++
+  "  or --package-db can be used to act on another database\n"++
+  "  entirely. When multiple of these options are given, the rightmost\n"++
+  "  one is used as the database to act upon.\n"++
+  "\n"++
+  "  Commands that query the package database (list, tree, latest, describe,\n"++
+  "  field) operate on the list of databases specified by the flags\n"++
+  "  --user, --global, and --package-db.  If none of these flags are\n"++
+  "  given, the default is --global --user.\n"++
+  "\n" ++
+  " The following optional flags are also accepted:\n"
+
+substProg :: String -> String -> String
+substProg _ [] = []
+substProg prog ('$':'p':xs) = prog ++ substProg prog xs
+substProg prog (c:xs) = c : substProg prog xs
+
+-- -----------------------------------------------------------------------------
+-- Do the business
+
+data Force = NoForce | ForceFiles | ForceAll | CannotForce
+  deriving (Eq,Ord)
+
+data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
+
+runit :: Verbosity -> [Flag] -> [String] -> IO ()
+runit verbosity cli nonopts = do
+  installSignalHandlers -- catch ^C and clean up
+  prog <- getProgramName
+  let
+        force
+          | FlagForce `elem` cli        = ForceAll
+          | FlagForceFiles `elem` cli   = ForceFiles
+          | otherwise                   = NoForce
+        auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+        expand_env_vars= FlagExpandEnvVars `elem` cli
+        mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
+          where accumExpandPkgroot _ FlagExpandPkgroot   = Just True
+                accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
+                accumExpandPkgroot x _                   = x
+                
+        splitFields fields = unfoldr splitComma (',':fields)
+          where splitComma "" = Nothing
+                splitComma fs = Just $ break (==',') (tail fs)
+
+        substringCheck :: String -> Maybe (String -> Bool)
+        substringCheck ""    = Nothing
+        substringCheck "*"   = Just (const True)
+        substringCheck [_]   = Nothing
+        substringCheck (h:t) =
+          case (h, init t, last t) of
+            ('*',s,'*') -> Just (isInfixOf (f s) . f)
+            ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
+            ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
+            _           -> Nothing
+          where f | FlagIgnoreCase `elem` cli = map toLower
+                  | otherwise                 = id
+#if defined(GLOB)
+        glob x | System.Info.os=="mingw32" = do
+          -- glob echoes its argument, after win32 filename globbing
+          (_,o,_,_) <- runInteractiveCommand ("glob "++x)
+          txt <- hGetContents o
+          return (read txt)
+        glob x | otherwise = return [x]
+#endif
+  --
+  -- first, parse the command
+  case nonopts of
+#if defined(GLOB)
+    -- dummy command to demonstrate usage and permit testing
+    -- without messing things up; use glob to selectively enable
+    -- windows filename globbing for file parameters
+    -- register, update, FlagGlobalConfig, FlagConfig; others?
+    ["glob", filename] -> do
+        print filename
+        glob filename >>= print
+#endif
+    ["init", filename] ->
+        initPackageDB filename verbosity cli
+    ["register", filename] ->
+        registerPackage filename verbosity cli
+                        auto_ghci_libs expand_env_vars False force
+    ["update", filename] ->
+        registerPackage filename verbosity cli
+                        auto_ghci_libs expand_env_vars True force
+    ["unregister", pkgid_str] -> do
+        pkgid <- readGlobPkgId pkgid_str
+        unregisterPackage pkgid verbosity cli force
+    ["expose", pkgid_str] -> do
+        pkgid <- readGlobPkgId pkgid_str
+        exposePackage pkgid verbosity cli force
+    ["hide",   pkgid_str] -> do
+        pkgid <- readGlobPkgId pkgid_str
+        hidePackage pkgid verbosity cli force
+    ["trust",    pkgid_str] -> do
+        pkgid <- readGlobPkgId pkgid_str
+        trustPackage pkgid verbosity cli force
+    ["distrust", pkgid_str] -> do
+        pkgid <- readGlobPkgId pkgid_str
+        distrustPackage pkgid verbosity cli force
+    ["list"] -> do
+        listPackages verbosity cli Nothing Nothing
+    ["list", pkgid_str] ->
+        case substringCheck pkgid_str of
+          Nothing -> do pkgid <- readGlobPkgId pkgid_str
+                        listPackages verbosity cli (Just (Id pkgid)) Nothing
+          Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
+    ["dot"] -> do
+        showPackageDot verbosity cli
+    ["find-module", moduleName] -> do
+        let match = maybe (==moduleName) id (substringCheck moduleName)
+        listPackages verbosity cli Nothing (Just match)
+    ["latest", pkgid_str] -> do
+        pkgid <- readGlobPkgId pkgid_str
+        latestPackage verbosity cli pkgid
+    ["describe", pkgid_str] -> do
+        pkgarg <- case substringCheck pkgid_str of
+          Nothing -> liftM Id (readGlobPkgId pkgid_str)
+          Just m  -> return (Substring pkgid_str m)
+        describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
+        
+    ["field", pkgid_str, fields] -> do
+        pkgarg <- case substringCheck pkgid_str of
+          Nothing -> liftM Id (readGlobPkgId pkgid_str)
+          Just m  -> return (Substring pkgid_str m)
+        describeField verbosity cli pkgarg
+                      (splitFields fields) (fromMaybe True mexpand_pkgroot)
+
+    ["check"] -> do
+        checkConsistency verbosity cli
+
+    ["dump"] -> do
+        dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
+
+    ["recache"] -> do
+        recache verbosity cli
+
+    [] -> do
+        die ("missing command\n" ++ shortUsage prog)
+    (_cmd:_) -> do
+        die ("command-line syntax error\n" ++ shortUsage prog)
+
+parseCheck :: ReadP a a -> String -> String -> IO a
+parseCheck parser str what =
+  case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
+    [x] -> return x
+    _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
+
+readGlobPkgId :: String -> IO PackageIdentifier
+readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
+
+parseGlobPackageId :: ReadP r PackageIdentifier
+parseGlobPackageId =
+  parse
+     +++
+  (do n <- parse
+      _ <- string "-*"
+      return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
+
+-- globVersion means "all versions"
+globVersion :: Version
+globVersion = Version{ versionBranch=[], versionTags=["*"] }
+
+-- -----------------------------------------------------------------------------
+-- Package databases
+
+-- Some commands operate on a single database:
+--      register, unregister, expose, hide, trust, distrust
+-- however these commands also check the union of the available databases
+-- in order to check consistency.  For example, register will check that
+-- dependencies exist before registering a package.
+--
+-- Some commands operate  on multiple databases, with overlapping semantics:
+--      list, describe, field
+
+data PackageDB 
+  = PackageDB {
+      location, locationAbsolute :: !FilePath,
+      -- We need both possibly-relative and definately-absolute package
+      -- db locations. This is because the relative location is used as
+      -- an identifier for the db, so it is important we do not modify it.
+      -- On the other hand we need the absolute path in a few places
+      -- particularly in relation to the ${pkgroot} stuff.
+      
+      packages :: [InstalledPackageInfo]
+    }
+
+type PackageDBStack = [PackageDB]
+        -- A stack of package databases.  Convention: head is the topmost
+        -- in the stack.
+
+allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
+allPackagesInStack = concatMap packages
+
+getPkgDatabases :: Verbosity
+                -> Bool    -- we are modifying, not reading
+                -> Bool    -- read caches, if available
+                -> Bool    -- expand vars, like ${pkgroot} and $topdir
+                -> [Flag]
+                -> IO (PackageDBStack, 
+                          -- the real package DB stack: [global,user] ++ 
+                          -- DBs specified on the command line with -f.
+                       Maybe FilePath,
+                          -- which one to modify, if any
+                       PackageDBStack)
+                          -- the package DBs specified on the command
+                          -- line, or [global,user] otherwise.  This
+                          -- is used as the list of package DBs for
+                          -- commands that just read the DB, such as 'list'.
+
+getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
+  -- first we determine the location of the global package config.  On Windows,
+  -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
+  -- location is passed to the binary using the --global-package-db flag by the
+  -- wrapper script.
+  let err_msg = "missing --global-package-db option, location of global package database unknown\n"
+  global_conf <-
+     case [ f | FlagGlobalConfig f <- my_flags ] of
+        [] -> do mb_dir <- getLibDir
+                 case mb_dir of
+                   Nothing  -> die err_msg
+                   Just dir -> do
+                     r <- lookForPackageDBIn dir
+                     case r of
+                       Nothing -> die ("Can't find package database in " ++ dir)
+                       Just path -> return path
+        fs -> return (last fs)
+
+  -- The value of the $topdir variable used in some package descriptions
+  -- Note that the way we calculate this is slightly different to how it
+  -- is done in ghc itself. We rely on the convention that the global
+  -- package db lives in ghc's libdir.
+  top_dir <- absolutePath (takeDirectory global_conf)
+
+  let no_user_db = FlagNoUserDb `elem` my_flags
+
+  mb_user_conf <-
+     if no_user_db then return Nothing else do
+         r <- lookForPackageDBIn hasteUserDir
+         case r of
+           Nothing -> return (Just (pkgUserDir, False))
+           Just f  -> return (Just (f, True))
+
+  -- If the user database doesn't exist, and this command isn't a
+  -- "modify" command, then we won't attempt to create or use it.
+  let sys_databases
+        | Just (user_conf,user_exists) <- mb_user_conf,
+          modify || user_exists = [user_conf, global_conf]
+        | otherwise             = [global_conf]
+
+  e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
+  let env_stack =
+        case e_pkg_path of
+                Left  _ -> sys_databases
+                Right path
+                  | last cs == ""  -> init cs ++ sys_databases
+                  | otherwise      -> cs
+                  where cs = parseSearchPath path
+
+        -- The "global" database is always the one at the bottom of the stack.
+        -- This is the database we modify by default.
+      virt_global_conf = last env_stack
+
+  let db_flags = [ f | Just f <- map is_db_flag my_flags ]
+         where is_db_flag FlagUser
+                      | Just (user_conf, _user_exists) <- mb_user_conf 
+                      = Just user_conf
+               is_db_flag FlagGlobal     = Just virt_global_conf
+               is_db_flag (FlagConfig f) = Just f
+               is_db_flag _              = Nothing
+
+  let flag_db_names | null db_flags = env_stack
+                    | otherwise     = reverse (nub db_flags)
+
+  -- For a "modify" command, treat all the databases as
+  -- a stack, where we are modifying the top one, but it
+  -- can refer to packages in databases further down the
+  -- stack.
+
+  -- -f flags on the command line add to the database
+  -- stack, unless any of them are present in the stack
+  -- already.
+  let final_stack = filter (`notElem` env_stack)
+                     [ f | FlagConfig f <- reverse my_flags ]
+                     ++ env_stack
+
+  -- the database we actually modify is the one mentioned
+  -- rightmost on the command-line.
+  let to_modify
+        | not modify    = Nothing
+        | null db_flags = Just virt_global_conf
+        | otherwise     = Just (last db_flags)
+
+  db_stack  <- sequence
+    [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+         if expand_vars then return (mungePackageDBPaths top_dir db)
+                        else return db
+    | db_path <- final_stack ]
+
+  let flag_db_stack = [ db | db_name <- flag_db_names,
+                        db <- db_stack, location db == db_name ]
+
+  return (db_stack, to_modify, flag_db_stack)
+
+
+lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
+lookForPackageDBIn dir = do
+  let path_dir = dir </> "package.conf.d"
+  exists_dir <- doesDirectoryExist path_dir
+  if exists_dir then return (Just path_dir) else do
+    let path_file = dir </> "package.conf"
+    exists_file <- doesFileExist path_file
+    if exists_file then return (Just path_file) else return Nothing
+
+readParseDatabase :: Verbosity
+                  -> Maybe (FilePath,Bool)
+                  -> Bool -- use cache
+                  -> FilePath
+                  -> IO PackageDB
+
+readParseDatabase verbosity mb_user_conf use_cache path
+  -- the user database (only) is allowed to be non-existent
+  | Just (user_conf,False) <- mb_user_conf, path == user_conf
+  = mkPackageDB []
+  | otherwise
+  = do e <- tryIO $ getDirectoryContents path
+       case e of
+         Left _   -> do
+              pkgs <- parseMultiPackageConf verbosity path
+              mkPackageDB pkgs
+         Right fs
+           | not use_cache -> ignore_cache (const $ return ())
+           | otherwise -> do
+              let cache = path </> cachefilename
+              tdir     <- getModificationTime path
+              e_tcache <- tryIO $ getModificationTime cache
+              case e_tcache of
+                Left ex -> do
+                     when (verbosity > Normal) $
+                        warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
+                     ignore_cache (const $ return ())
+                Right tcache -> do
+                  let compareTimestampToCache file =
+                          when (verbosity >= Verbose) $ do
+                              tFile <- getModificationTime file
+                              compareTimestampToCache' file tFile
+                      compareTimestampToCache' file tFile = do
+                          let rel = case tcache `compare` tFile of
+                                    LT -> " (NEWER than cache)"
+                                    GT -> " (older than cache)"
+                                    EQ -> " (same as cache)"
+                          warn ("Timestamp " ++ show tFile
+                             ++ " for " ++ file ++ rel)
+                  when (verbosity >= Verbose) $ do
+                      warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
+                      compareTimestampToCache' path tdir
+                  if tcache >= tdir
+                      then do
+                          when (verbosity > Normal) $
+                             infoLn ("using cache: " ++ cache)
+                          pkgs <- myReadBinPackageDB cache
+                          let pkgs' = map convertPackageInfoIn pkgs
+                          mkPackageDB pkgs'
+                      else do
+                          when (verbosity >= Normal) $ do
+                              warn ("WARNING: cache is out of date: "
+                                 ++ cache)
+                              warn "Use 'ghc-pkg recache' to fix."
+                          ignore_cache compareTimestampToCache
+            where
+                 ignore_cache :: (FilePath -> IO ()) -> IO PackageDB
+                 ignore_cache checkTime = do
+                     let confs = filter (".conf" `isSuffixOf`) fs
+                         doFile f = do checkTime f
+                                       parseSingletonPackageConf verbosity f
+                     pkgs <- mapM doFile $ map (path </>) confs
+                     mkPackageDB pkgs
+  where
+    mkPackageDB pkgs = do
+      path_abs <- absolutePath path
+      return PackageDB {
+        location = path,
+        locationAbsolute = path_abs,
+        packages = pkgs
+      }
+
+-- read the package.cache file strictly, to work around a problem with
+-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
+-- after it has been completely read, leading to a sharing violation
+-- later.
+myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]
+myReadBinPackageDB filepath = do
+  h <- openBinaryFile filepath ReadMode
+  sz <- hFileSize h
+  b <- B.hGet h (fromIntegral sz)
+  hClose h
+  return $ Bin.runGet Bin.get b
+
+parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
+parseMultiPackageConf verbosity file = do
+  when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)
+  str <- readUTF8File file
+  let pkgs = map convertPackageInfoIn $ read str
+  Exception.evaluate pkgs
+    `catchError` \e->
+       die ("error while parsing " ++ file ++ ": " ++ show e)
+  
+parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
+parseSingletonPackageConf verbosity file = do
+  when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
+  readUTF8File file >>= fmap fst . parsePackageInfo
+
+cachefilename :: FilePath
+cachefilename = "package.cache"
+
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+    db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+  where
+    pkgroot = takeDirectory (locationAbsolute db)    
+    -- It so happens that for both styles of package db ("package.conf"
+    -- files and "package.conf.d" dirs) the pkgroot is the parent directory
+    -- ${pkgroot}/package.conf  or  ${pkgroot}/package.conf.d/
+
+-- TODO: This code is duplicated in compiler/main/Packages.lhs
+mungePackagePaths :: FilePath -> FilePath
+                  -> InstalledPackageInfo -> InstalledPackageInfo
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+    pkg {
+      importDirs  = munge_paths (importDirs pkg),
+      includeDirs = munge_paths (includeDirs pkg),
+      libraryDirs = munge_paths (libraryDirs pkg),
+      frameworkDirs = munge_paths (frameworkDirs pkg),
+      haddockInterfaces = munge_paths (haddockInterfaces pkg),
+                     -- haddock-html is allowed to be either a URL or a file
+      haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
+    }
+  where
+    munge_paths = map munge_path
+    munge_urls  = map munge_url
+
+    munge_path p
+      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
+      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
+      | otherwise                                = p
+
+    munge_url p
+      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
+      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
+      | otherwise                                   = p
+
+    toUrlPath r p = "file:///"
+                 -- URLs always use posix style '/' separators:
+                 ++ FilePath.Posix.joinPath
+                        (r : -- We need to drop a leading "/" or "\\"
+                             -- if there is one:
+                             dropWhile (all isPathSeparator)
+                                       (FilePath.splitDirectories p))
+
+    -- We could drop the separator here, and then use </> above. However,
+    -- by leaving it in and using ++ we keep the same path separator
+    -- rather than letting FilePath change it to use \ as the separator
+    stripVarPrefix var path = case stripPrefix var path of
+                              Just [] -> Just []
+                              Just cs@(c : _) | isPathSeparator c -> Just cs
+                              _ -> Nothing
+
+
+-- -----------------------------------------------------------------------------
+-- Creating a new package DB
+
+initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()
+initPackageDB filename verbosity _flags = do
+  let eexist = die ("cannot create: " ++ filename ++ " already exists")
+  b1 <- doesFileExist filename
+  when b1 eexist
+  b2 <- doesDirectoryExist filename
+  when b2 eexist
+  filename_abs <- absolutePath filename
+  changeDB verbosity [] PackageDB {
+                          location = filename, locationAbsolute = filename_abs,
+                          packages = []
+                        }
+
+-- -----------------------------------------------------------------------------
+-- Registering
+
+registerPackage :: FilePath
+                -> Verbosity
+                -> [Flag]
+                -> Bool              -- auto_ghci_libs
+                -> Bool              -- expand_env_vars
+                -> Bool              -- update
+                -> Force
+                -> IO ()
+registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
+  (db_stack, Just to_modify, _flag_dbs) <- 
+      getPkgDatabases verbosity True True False{-expand vars-} my_flags
+
+  let
+        db_to_operate_on = my_head "register" $
+                           filter ((== to_modify).location) db_stack
+  --
+  when (auto_ghci_libs && verbosity >= Silent) $
+    warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
+  --
+  s <-
+    case input of
+      "-" -> do
+        when (verbosity >= Normal) $
+            info "Reading package info from stdin ... "
+        -- fix the encoding to UTF-8, since this is an interchange format
+        hSetEncoding stdin utf8
+        getContents
+      f   -> do
+        when (verbosity >= Normal) $
+            info ("Reading package info from " ++ show f ++ " ... ")
+        readUTF8File f
+
+  expanded <- if expand_env_vars then expandEnvVars s force
+                                 else return s
+
+  (pkg, ws) <- parsePackageInfo expanded
+  when (verbosity >= Normal) $
+      infoLn "done."
+
+  -- report any warnings from the parse phase
+  _ <- reportValidateErrors [] ws
+         (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+
+  -- validate the expanded pkg, but register the unexpanded
+  pkgroot <- absolutePath (takeDirectory to_modify)
+  let top_dir = takeDirectory (location (last db_stack))
+      pkg_expanded = mungePackagePaths top_dir pkgroot pkg
+
+  let truncated_stack = dropWhile ((/= to_modify).location) db_stack
+  -- truncate the stack for validation, because we don't allow
+  -- packages lower in the stack to refer to those higher up.
+  validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force
+  let 
+     removes = [ RemovePackage p
+               | p <- packages db_to_operate_on,
+                 sourcePackageId p == sourcePackageId pkg ]
+  --
+  changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
+
+parsePackageInfo
+        :: String
+        -> IO (InstalledPackageInfo, [ValidateWarning])
+parsePackageInfo str =
+  case parseInstalledPackageInfo str of
+    ParseOk warnings ok -> return (ok, ws)
+      where
+        ws = [ msg | PWarning msg <- warnings
+                   , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
+    ParseFailed err -> case locatedErrorMsg err of
+                           (Nothing, s) -> die s
+                           (Just l, s) -> die (show l ++ ": " ++ s)
+
+-- -----------------------------------------------------------------------------
+-- Making changes to a package database
+
+data DBOp = RemovePackage InstalledPackageInfo
+          | AddPackage    InstalledPackageInfo
+          | ModifyPackage InstalledPackageInfo
+
+changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
+changeDB verbosity cmds db = do
+  let db' = updateInternalDB db cmds
+  isfile <- doesFileExist (location db)
+  if isfile
+     then writeNewConfig verbosity (location db') (packages db')
+     else do
+       createDirectoryIfMissing True (location db)
+       changeDBDir verbosity cmds db'
+
+updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
+updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
+ where
+  do_cmd pkgs (RemovePackage p) = 
+    filter ((/= installedPackageId p) . installedPackageId) pkgs
+  do_cmd pkgs (AddPackage p) = p : pkgs
+  do_cmd pkgs (ModifyPackage p) = 
+    do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
+    
+
+changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
+changeDBDir verbosity cmds db = do
+  mapM_ do_cmd cmds
+  updateDBCache verbosity db
+ where
+  do_cmd (RemovePackage p) = do
+    let file = location db </> display (installedPackageId p) <.> "conf"
+    when (verbosity > Normal) $ infoLn ("removing " ++ file)
+    removeFileSafe file
+  do_cmd (AddPackage p) = do
+    let file = location db </> display (installedPackageId p) <.> "conf"
+    when (verbosity > Normal) $ infoLn ("writing " ++ file)
+    writeFileUtf8Atomic file (showInstalledPackageInfo p)
+  do_cmd (ModifyPackage p) = 
+    do_cmd (AddPackage p)
+
+updateDBCache :: Verbosity -> PackageDB -> IO ()
+updateDBCache verbosity db = do
+  let filename = location db </> cachefilename
+  when (verbosity > Normal) $
+      infoLn ("writing cache " ++ filename)
+  writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
+    `catchIO` \e ->
+      if isPermissionError e
+      then die (filename ++ ": you don't have permission to modify this file")
+      else ioError e
+#ifndef mingw32_HOST_OS
+  status <- getFileStatus filename
+  setFileTimes (location db) (accessTime status) (modificationTime status)
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar
+
+exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})
+
+hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})
+
+trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})
+
+distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})
+
+unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
+unregisterPackage = modifyPackage RemovePackage
+
+modifyPackage
+  :: (InstalledPackageInfo -> DBOp)
+  -> PackageIdentifier
+  -> Verbosity
+  -> [Flag]
+  -> Force
+  -> IO ()
+modifyPackage fn pkgid verbosity my_flags force = do
+  (db_stack, Just _to_modify, _flag_dbs) <- 
+      getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
+
+  (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
+  let 
+      db_name = location db
+      pkgs    = packages db
+
+      pids = map sourcePackageId ps
+
+      cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
+      new_db = updateInternalDB db cmds
+
+      old_broken = brokenPackages (allPackagesInStack db_stack)
+      rest_of_stack = filter ((/= db_name) . location) db_stack
+      new_stack = new_db : rest_of_stack
+      new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))
+      newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken
+  --
+  when (not (null newly_broken)) $
+      dieOrForceAll force ("unregistering " ++ display pkgid ++
+           " would break the following packages: "
+              ++ unwords (map display newly_broken))
+
+  changeDB verbosity cmds db
+
+recache :: Verbosity -> [Flag] -> IO ()
+recache verbosity my_flags = do
+  (db_stack, Just to_modify, _flag_dbs) <- 
+     getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
+  let
+        db_to_operate_on = my_head "recache" $
+                           filter ((== to_modify).location) db_stack
+  --
+  changeDB verbosity [] db_to_operate_on
+
+-- -----------------------------------------------------------------------------
+-- Listing packages
+
+listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
+             -> Maybe (String->Bool)
+             -> IO ()
+listPackages verbosity my_flags mPackageName mModuleName = do
+  let simple_output = FlagSimpleOutput `elem` my_flags
+  (db_stack, _, flag_db_stack) <- 
+     getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
+
+  let db_stack_filtered -- if a package is given, filter out all other packages
+        | Just this <- mPackageName =
+            [ db{ packages = filter (this `matchesPkg`) (packages db) }
+            | db <- flag_db_stack ]
+        | Just match <- mModuleName = -- packages which expose mModuleName
+            [ db{ packages = filter (match `exposedInPkg`) (packages db) }
+            | db <- flag_db_stack ]
+        | otherwise = flag_db_stack
+
+      db_stack_sorted
+          = [ db{ packages = sort_pkgs (packages db) }
+            | db <- db_stack_filtered ]
+          where sort_pkgs = sortBy cmpPkgIds
+                cmpPkgIds pkg1 pkg2 =
+                   case pkgName p1 `compare` pkgName p2 of
+                        LT -> LT
+                        GT -> GT
+                        EQ -> pkgVersion p1 `compare` pkgVersion p2
+                   where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)
+
+      stack = reverse db_stack_sorted
+
+      match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
+
+      pkg_map = allPackagesInStack db_stack
+      broken = map sourcePackageId (brokenPackages pkg_map)
+
+      show_normal PackageDB{ location = db_name, packages = pkg_confs } =
+          do hPutStrLn stdout (db_name ++ ":")
+             if null pp_pkgs
+                 then hPutStrLn stdout "    (no packages)"
+                 else hPutStrLn stdout $ unlines (map ("    " ++) pp_pkgs)
+           where
+                 -- Sort using instance Ord PackageId
+                 pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs
+                 pp_pkg p
+                   | sourcePackageId p `elem` broken = printf "{%s}" doc
+                   | exposed p = doc
+                   | otherwise = printf "(%s)" doc
+                   where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid
+                             | otherwise            = pkg
+                          where
+                          InstalledPackageId ipid = installedPackageId p
+                          pkg = display (sourcePackageId p)
+
+      show_simple = simplePackageList my_flags . allPackagesInStack
+
+  when (not (null broken) && not simple_output && verbosity /= Silent) $ do
+     prog <- getProgramName
+     warn ("WARNING: there are broken packages.  Run '" ++ prog ++ " check' for more details.")
+
+  if simple_output then show_simple stack else do
+
+#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
+    mapM_ show_normal stack
+#else
+    let
+       show_colour withF db =
+           mconcat $ map (<#> termText "\n") $
+               (termText (location db) :
+                  map (termText "   " <#>) (map pp_pkg (packages db)))
+          where
+                   pp_pkg p
+                     | sourcePackageId p `elem` broken = withF Red  doc
+                     | exposed p                       = doc
+                     | otherwise                       = withF Blue doc
+                     where doc | verbosity >= Verbose
+                               = termText (printf "%s (%s)" pkg ipid)
+                               | otherwise
+                               = termText pkg
+                            where
+                            InstalledPackageId ipid = installedPackageId p
+                            pkg = display (sourcePackageId p)
+
+    is_tty <- hIsTerminalDevice stdout
+    if not is_tty
+       then mapM_ show_normal stack
+       else do tty <- Terminfo.setupTermFromEnv
+               case Terminfo.getCapability tty withForegroundColor of
+                   Nothing -> mapM_ show_normal stack
+                   Just w  -> runTermOutput tty $ mconcat $
+                                                  map (show_colour w) stack
+#endif
+
+simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
+simplePackageList my_flags pkgs = do
+   let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
+                                                  else display
+       -- Sort using instance Ord PackageId
+       strs = map showPkg $ sort $ map sourcePackageId pkgs
+   when (not (null pkgs)) $
+      hPutStrLn stdout $ concat $ intersperse " " strs
+
+showPackageDot :: Verbosity -> [Flag] -> IO ()
+showPackageDot verbosity myflags = do
+  (_, _, flag_db_stack) <- 
+      getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
+
+  let all_pkgs = allPackagesInStack flag_db_stack
+      ipix  = PackageIndex.fromList all_pkgs
+
+  putStrLn "digraph {"
+  let quote s = '"':s ++ "\""
+  mapM_ putStrLn [ quote from ++ " -> " ++ quote to
+                 | p <- all_pkgs,
+                   let from = display (sourcePackageId p),
+                   depid <- depends p,
+                   Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],
+                   let to = display (sourcePackageId dep)
+                 ]
+  putStrLn "}"
+
+-- -----------------------------------------------------------------------------
+-- Prints the highest (hidden or exposed) version of a package
+
+latestPackage ::  Verbosity -> [Flag] -> PackageIdentifier -> IO ()
+latestPackage verbosity my_flags pkgid = do
+  (_, _, flag_db_stack) <- 
+     getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
+
+  ps <- findPackages flag_db_stack (Id pkgid)
+  case ps of
+    [] -> die "no matches"
+    _  -> show_pkg . maximum . map sourcePackageId $ ps
+  where
+    show_pkg pid = hPutStrLn stdout (display pid)
+
+-- -----------------------------------------------------------------------------
+-- Describe
+
+describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
+describePackage verbosity my_flags pkgarg expand_pkgroot = do
+  (_, _, flag_db_stack) <- 
+      getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  dbs <- findPackagesByDB flag_db_stack pkgarg
+  doDump expand_pkgroot [ (pkg, locationAbsolute db)
+                        | (db, pkgs) <- dbs, pkg <- pkgs ]
+
+dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
+dumpPackages verbosity my_flags expand_pkgroot = do
+  (_, _, flag_db_stack) <- 
+     getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  doDump expand_pkgroot [ (pkg, locationAbsolute db)
+                        | db <- flag_db_stack, pkg <- packages db ]
+
+doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump expand_pkgroot pkgs = do
+  -- fix the encoding to UTF-8, since this is an interchange format
+  hSetEncoding stdout utf8
+  putStrLn $
+    intercalate "---\n"
+    [ if expand_pkgroot
+        then showInstalledPackageInfo pkg
+        else showInstalledPackageInfo pkg ++ pkgrootField
+    | (pkg, pkgloc) <- pkgs
+    , let pkgroot      = takeDirectory pkgloc
+          pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]
+
+-- PackageId is can have globVersion for the version
+findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
+findPackages db_stack pkgarg
+  = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
+
+findPackagesByDB :: PackageDBStack -> PackageArg
+                 -> IO [(PackageDB, [InstalledPackageInfo])]
+findPackagesByDB db_stack pkgarg
+  = case [ (db, matched)
+         | db <- db_stack,
+           let matched = filter (pkgarg `matchesPkg`) (packages db),
+           not (null matched) ] of
+        [] -> die ("cannot find package " ++ pkg_msg pkgarg)
+        ps -> return ps
+  where
+        pkg_msg (Id pkgid)           = display pkgid
+        pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
+
+matches :: PackageIdentifier -> PackageIdentifier -> Bool
+pid `matches` pid'
+  = (pkgName pid == pkgName pid')
+    && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
+
+realVersion :: PackageIdentifier -> Bool
+realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
+  -- when versionBranch == [], this is a glob
+
+matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
+(Id pid)        `matchesPkg` pkg = pid `matches` sourcePackageId pkg
+(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))
+
+-- -----------------------------------------------------------------------------
+-- Field
+
+describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
+describeField verbosity my_flags pkgarg fields expand_pkgroot = do
+  (_, _, flag_db_stack) <- 
+      getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+  fns <- mapM toField fields
+  ps <- findPackages flag_db_stack pkgarg
+  mapM_ (selectFields fns) ps
+  where showFun = if FlagSimpleOutput `elem` my_flags
+                  then showSimpleInstalledPackageInfoField
+                  else showInstalledPackageInfoField
+        toField f = case showFun f of
+                    Nothing -> die ("unknown field: " ++ f)
+                    Just fn -> return fn
+        selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns
+
+
+-- -----------------------------------------------------------------------------
+-- Check: Check consistency of installed packages
+
+checkConsistency :: Verbosity -> [Flag] -> IO ()
+checkConsistency verbosity my_flags = do
+  (db_stack, _, _) <- 
+         getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
+         -- check behaves like modify for the purposes of deciding which
+         -- databases to use, because ordering is important.
+
+  let simple_output = FlagSimpleOutput `elem` my_flags
+
+  let pkgs = allPackagesInStack db_stack
+
+      checkPackage p = do
+         (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True
+         if null es
+            then do when (not simple_output) $ do
+                      _ <- reportValidateErrors [] ws "" Nothing
+                      return ()
+                    return []
+            else do
+              when (not simple_output) $ do
+                  reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")
+                  _ <- reportValidateErrors es ws "  " Nothing
+                  return ()
+              return [p]
+
+  broken_pkgs <- concat `fmap` mapM checkPackage pkgs
+
+  let filterOut pkgs1 pkgs2 = filter not_in pkgs2
+        where not_in p = sourcePackageId p `notElem` all_ps
+              all_ps = map sourcePackageId pkgs1
+
+  let not_broken_pkgs = filterOut broken_pkgs pkgs
+      (_, trans_broken_pkgs) = closure [] not_broken_pkgs
+      all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
+
+  when (not (null all_broken_pkgs)) $ do
+    if simple_output
+      then simplePackageList my_flags all_broken_pkgs
+      else do
+       reportError ("\nThe following packages are broken, either because they have a problem\n"++
+                "listed above, or because they depend on a broken package.")
+       mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs
+
+  when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
+
+
+closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+        -> ([InstalledPackageInfo], [InstalledPackageInfo])
+closure pkgs db_stack = go pkgs db_stack
+ where
+   go avail not_avail =
+     case partition (depsAvailable avail) not_avail of
+        ([],        not_avail') -> (avail, not_avail')
+        (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
+
+   depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
+                 -> Bool
+   depsAvailable pkgs_ok pkg = null dangling
+        where dangling = filter (`notElem` pids) (depends pkg)
+              pids = map installedPackageId pkgs_ok
+
+        -- we want mutually recursive groups of package to show up
+        -- as broken. (#1750)
+
+brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+brokenPackages pkgs = snd (closure [] pkgs)
+
+-- -----------------------------------------------------------------------------
+-- Manipulating package.conf files
+
+type InstalledPackageInfoString = InstalledPackageInfo_ String
+
+convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
+convertPackageInfoOut
+    (pkgconf@(InstalledPackageInfo { exposedModules = e,
+                                     hiddenModules = h })) =
+        pkgconf{ exposedModules = map display e,
+                 hiddenModules  = map display h }
+
+convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
+convertPackageInfoIn
+    (pkgconf@(InstalledPackageInfo { exposedModules = e,
+                                     hiddenModules = h })) =
+        pkgconf{ exposedModules = map convert e,
+                 hiddenModules  = map convert h }
+    where convert = fromJust . simpleParse
+
+writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
+writeNewConfig verbosity filename ipis = do
+  when (verbosity >= Normal) $
+      info "Writing new package config file... "
+  createDirectoryIfMissing True $ takeDirectory filename
+  let shown = concat $ intersperse ",\n "
+                     $ map (show . convertPackageInfoOut) ipis
+      fileContents = "[" ++ shown ++ "\n]"
+  writeFileUtf8Atomic filename fileContents
+    `catchIO` \e ->
+      if isPermissionError e
+      then die (filename ++ ": you don't have permission to modify this file")
+      else ioError e
+  when (verbosity >= Normal) $
+      infoLn "done."
+
+-----------------------------------------------------------------------------
+-- Sanity-check a new package config, and automatically build GHCi libs
+-- if requested.
+
+type ValidateError   = (Force,String)
+type ValidateWarning = String
+
+newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }
+
+instance Functor Validate where
+    fmap = liftM
+
+instance Applicative Validate where
+    pure = return
+    (<*>) = ap
+
+instance Monad Validate where
+   return a = V $ return (a, [], [])
+   m >>= k = V $ do
+      (a, es, ws) <- runValidate m
+      (b, es', ws') <- runValidate (k a)
+      return (b,es++es',ws++ws')
+
+verror :: Force -> String -> Validate ()
+verror f s = V (return ((),[(f,s)],[]))
+
+vwarn :: String -> Validate ()
+vwarn s = V (return ((),[],["Warning: " ++ s]))
+
+liftIO :: IO a -> Validate a
+liftIO k = V (k >>= \a -> return (a,[],[]))
+
+-- returns False if we should die
+reportValidateErrors :: [ValidateError] -> [ValidateWarning]
+                     -> String -> Maybe Force -> IO Bool
+reportValidateErrors es ws prefix mb_force = do
+  mapM_ (warn . (prefix++)) ws
+  oks <- mapM report es
+  return (and oks)
+  where
+    report (f,s)
+      | Just force <- mb_force
+      = if (force >= f)
+           then do reportError (prefix ++ s ++ " (ignoring)")
+                   return True
+           else if f < CannotForce
+                   then do reportError (prefix ++ s ++ " (use --force to override)")
+                           return False
+                   else do reportError err
+                           return False
+      | otherwise = do reportError err
+                       return False
+      where
+             err = prefix ++ s
+
+validatePackageConfig :: InstalledPackageInfo
+                      -> Verbosity
+                      -> PackageDBStack
+                      -> Bool   -- auto-ghc-libs
+                      -> Bool   -- update, or check
+                      -> Force
+                      -> IO ()
+validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do
+  (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update
+  ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
+  when (not ok) $ exitWith (ExitFailure 1)
+
+checkPackageConfig :: InstalledPackageInfo
+                      -> Verbosity
+                      -> PackageDBStack
+                      -> Bool   -- auto-ghc-libs
+                      -> Bool   -- update, or check
+                      -> Validate ()
+checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do
+  checkInstalledPackageId pkg db_stack update
+  checkPackageId pkg
+  checkDuplicates db_stack pkg update
+  mapM_ (checkDep db_stack) (depends pkg)
+  checkDuplicateDepends (depends pkg)
+  mapM_ (checkDir False "import-dirs")  (importDirs pkg)
+  mapM_ (checkDir True  "library-dirs") (libraryDirs pkg)
+  mapM_ (checkDir True  "include-dirs") (includeDirs pkg)
+  mapM_ (checkDir True  "framework-dirs") (frameworkDirs pkg)
+  mapM_ (checkFile   True "haddock-interfaces") (haddockInterfaces pkg)
+  mapM_ (checkDirURL True "haddock-html")       (haddockHTMLs pkg)
+  checkModules pkg
+  mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
+  -- ToDo: check these somehow?
+  --    extra_libraries :: [String],
+  --    c_includes      :: [String],
+
+checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool 
+                        -> Validate ()
+checkInstalledPackageId ipi db_stack update = do
+  let ipid@(InstalledPackageId str) = installedPackageId ipi
+  when (null str) $ verror CannotForce "missing id field"
+  let dups = [ p | p <- allPackagesInStack db_stack, 
+                   installedPackageId p == ipid ]
+  when (not update && not (null dups)) $
+    verror CannotForce $
+        "package(s) with this id already exist: " ++ 
+         unwords (map (display.packageId) dups)
+
+-- When the package name and version are put together, sometimes we can
+-- end up with a package id that cannot be parsed.  This will lead to
+-- difficulties when the user wants to refer to the package later, so
+-- we check that the package id can be parsed properly here.
+checkPackageId :: InstalledPackageInfo -> Validate ()
+checkPackageId ipi =
+  let str = display (sourcePackageId ipi) in
+  case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
+    [_] -> return ()
+    []  -> verror CannotForce ("invalid package identifier: " ++ str)
+    _   -> verror CannotForce ("ambiguous package identifier: " ++ str)
+
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
+checkDuplicates db_stack pkg update = do
+  let
+        pkgid = sourcePackageId pkg
+        pkgs  = packages (head db_stack)
+  --
+  -- Check whether this package id already exists in this DB
+  --
+  when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
+       verror CannotForce $
+          "package " ++ display pkgid ++ " is already installed"
+
+  let
+        uncasep = map toLower . display
+        dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)
+
+  when (not update && not (null dups)) $ verror ForceAll $
+        "Package names may be treated case-insensitively in the future.\n"++
+        "Package " ++ display pkgid ++
+        " overlaps with: " ++ unwords (map display dups)
+
+checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
+checkDir  = checkPath False True
+checkFile = checkPath False False
+checkDirURL = checkPath True True
+
+checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
+checkPath url_ok is_dir warn_only thisfield d
+ | url_ok && ("http://"  `isPrefixOf` d
+           || "https://" `isPrefixOf` d) = return ()
+
+ | url_ok
+ , Just d' <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield d'
+
+   -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
+   -- variables having been expanded already, see mungePackagePaths.
+
+ | isRelative d = verror ForceFiles $
+                     thisfield ++ ": " ++ d ++ " is a relative path which "
+                  ++ "makes no sense (as there is nothing for it to be "
+                  ++ "relative to). You can make paths relative to the "
+                  ++ "package database itself by using ${pkgroot}."
+        -- relative paths don't make any sense; #4134
+ | otherwise = do
+   there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
+   when (not there) $
+       let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
+                                        ++ if is_dir then "directory" else "file"
+       in
+       if warn_only 
+          then vwarn msg
+          else verror ForceFiles msg
+
+checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
+checkDep db_stack pkgid
+  | pkgid `elem` pkgids = return ()
+  | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
+                                 ++ "\" doesn't exist")
+  where
+        all_pkgs = allPackagesInStack db_stack
+        pkgids = map installedPackageId all_pkgs
+
+checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
+checkDuplicateDepends deps
+  | null dups = return ()
+  | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
+                                     unwords (map display dups))
+  where
+       dups = [ p | (p:_:_) <- group (sort deps) ]
+
+checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()
+checkHSLib verbosity dirs auto_ghci_libs lib = do
+  let batch_lib_file = "lib" ++ lib ++ ".a"
+      filenames = ["lib" ++ lib ++ ".a",
+                   "lib" ++ lib ++ ".p_a",
+                   "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".so",
+                   "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".dylib",
+                            lib ++ "-ghc" ++ showVersion ghcVersion ++ ".dll"]
+  m <- liftIO $ doesFileExistOnPath filenames dirs
+  case m of
+    Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++
+                                  " on library path")
+    Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs
+
+doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath)
+doesFileExistOnPath filenames paths = go fullFilenames
+  where fullFilenames = [ (path, path </> filename)
+                        | filename <- filenames
+                        , path <- paths ]
+        go []             = return Nothing
+        go ((p, fp) : xs) = do b <- doesFileExist fp
+                               if b then return (Just p) else go xs
+
+checkModules :: InstalledPackageInfo -> Validate ()
+checkModules pkg = do
+  mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
+  where
+    findModule modl =
+      -- there's no interface file for GHC.Prim
+      unless (modl == fromString "GHC.Prim") $ do
+      let files = [ toFilePath modl <.> extension
+                  | extension <- ["hi", "p_hi", "dyn_hi" ] ]
+      m <- liftIO $ doesFileExistOnPath files (importDirs pkg)
+      when (isNothing m) $
+         verror ForceFiles ("cannot find any of " ++ show files)
+
+checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()
+checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build
+  | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file
+  | otherwise  = return ()
+ where
+    ghci_lib_file = lib <.> "o"
+
+-- automatically build the GHCi version of a batch lib,
+-- using ld --whole-archive.
+
+autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()
+autoBuildGHCiLib verbosity dir batch_file ghci_file = do
+  let ghci_lib_file  = dir ++ '/':ghci_file
+      batch_lib_file = dir ++ '/':batch_file
+  when (verbosity >= Normal) $
+    info ("building GHCi library " ++ ghci_lib_file ++ "...")
+#if defined(darwin_HOST_OS)
+  r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
+#elif defined(mingw32_HOST_OS)
+  execDir <- getLibDir
+  r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
+#else
+  r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
+#endif
+  when (r /= ExitSuccess) $ exitWith r
+  when (verbosity >= Normal) $
+    infoLn (" done.")
+
+-- -----------------------------------------------------------------------------
+-- Searching for modules
+
+#if not_yet
+
+findModules :: [FilePath] -> IO [String]
+findModules paths =
+  mms <- mapM searchDir paths
+  return (concat mms)
+
+searchDir path prefix = do
+  fs <- getDirectoryEntries path `catchIO` \_ -> return []
+  searchEntries path prefix fs
+
+searchEntries path prefix [] = return []
+searchEntries path prefix (f:fs)
+  | looks_like_a_module  =  do
+        ms <- searchEntries path prefix fs
+        return (prefix `joinModule` f : ms)
+  | looks_like_a_component  =  do
+        ms <- searchDir (path </> f) (prefix `joinModule` f)
+        ms' <- searchEntries path prefix fs
+        return (ms ++ ms')
+  | otherwise
+        searchEntries path prefix fs
+
+  where
+        (base,suffix) = splitFileExt f
+        looks_like_a_module =
+                suffix `elem` haskell_suffixes &&
+                all okInModuleName base
+        looks_like_a_component =
+                null suffix && all okInModuleName base
+
+okInModuleName c
+
+#endif
+
+-- ---------------------------------------------------------------------------
+-- expanding environment variables in the package configuration
+
+expandEnvVars :: String -> Force -> IO String
+expandEnvVars str0 force = go str0 ""
+ where
+   go "" acc = return $! reverse acc
+   go ('$':'{':str) acc | (var, '}':rest) <- break close str
+        = do value <- lookupEnvVar var
+             go rest (reverse value ++ acc)
+        where close c = c == '}' || c == '\n' -- don't span newlines
+   go (c:str) acc
+        = go str (c:acc)
+
+   lookupEnvVar :: String -> IO String
+   lookupEnvVar "pkgroot"    = return "${pkgroot}"    -- these two are special,
+   lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
+   lookupEnvVar nm =
+        catchIO (System.Environment.getEnv nm)
+           (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
+                                        show nm)
+                      return "")
+
+-----------------------------------------------------------------------------
+
+getProgramName :: IO String
+getProgramName = liftM (`withoutSuffix` ".bin") getProgName
+   where str `withoutSuffix` suff
+            | suff `isSuffixOf` str = take (length str - length suff) str
+            | otherwise             = str
+
+bye :: String -> IO a
+bye s = putStr s >> exitWith ExitSuccess
+
+die :: String -> IO a
+die = dieWith 1
+
+dieWith :: Int -> String -> IO a
+dieWith ec s = do
+  prog <- getProgramName
+  reportError (prog ++ ": " ++ s)
+  exitWith (ExitFailure ec)
+
+dieOrForceAll :: Force -> String -> IO ()
+dieOrForceAll ForceAll s = ignoreError s
+dieOrForceAll _other s   = dieForcible s
+
+warn :: String -> IO ()
+warn = reportError
+
+-- send info messages to stdout
+infoLn :: String -> IO ()
+infoLn = putStrLn
+
+info :: String -> IO ()
+info = putStr
+
+ignoreError :: String -> IO ()
+ignoreError s = reportError (s ++ " (ignoring)")
+
+reportError :: String -> IO ()
+reportError s = do hFlush stdout; hPutStrLn stderr s
+
+dieForcible :: String -> IO ()
+dieForcible s = die (s ++ " (use --force to override)")
+
+my_head :: String -> [a] -> a
+my_head s []      = error s
+my_head _ (x : _) = x
+
+getLibDir :: IO (Maybe String)
+getLibDir = return $ Just hasteSysDir
+
+-----------------------------------------
+-- Adapted from ghc/compiler/utils/Panic
+
+installSignalHandlers :: IO ()
+installSignalHandlers = do
+  threadid <- myThreadId
+  let
+      interrupt = Exception.throwTo threadid
+                                    (Exception.ErrorCall "interrupted")
+  --
+#if !defined(mingw32_HOST_OS)
+  _ <- installHandler sigQUIT (Catch interrupt) Nothing
+  _ <- installHandler sigINT  (Catch interrupt) Nothing
+  return ()
+#else
+  -- GHC 6.3+ has support for console events on Windows
+  -- NOTE: running GHCi under a bash shell for some reason requires
+  -- you to press Ctrl-Break rather than Ctrl-C to provoke
+  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
+  -- why --SDM 17/12/2004
+  let sig_handler ControlC = interrupt
+      sig_handler Break    = interrupt
+      sig_handler _        = return ()
+
+  _ <- installHandler (Catch sig_handler)
+  return ()
+#endif
+
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+throwIOIO :: Exception.IOException -> IO a
+throwIOIO = Exception.throwIO
+#endif
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+catchIO = Exception.catch
+
+catchError :: IO a -> (String -> IO a) -> IO a
+catchError io handler = io `Exception.catch` handler'
+    where handler' (Exception.ErrorCall err) = handler err
+
+tryIO :: IO a -> IO (Either Exception.IOException a)
+tryIO = Exception.try
+
+writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
+writeBinaryFileAtomic targetFile obj =
+  withFileAtomic targetFile $ \h -> do
+     hSetBinaryMode h True
+     B.hPutStr h (Bin.encode obj)
+
+writeFileUtf8Atomic :: FilePath -> String -> IO ()
+writeFileUtf8Atomic targetFile content =
+  withFileAtomic targetFile $ \h -> do
+     hSetEncoding h utf8
+     hPutStr h content
+
+-- copied from Cabal's Distribution.Simple.Utils, except that we want
+-- to use text files here, rather than binary files.
+withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()
+withFileAtomic targetFile write_content = do
+  (newFile, newHandle) <- openNewFile targetDir template
+  do  write_content newHandle
+      hClose newHandle
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+      renameFile newFile targetFile
+        -- If the targetFile exists then renameFile will fail
+        `catchIO` \err -> do
+          exists <- doesFileExist targetFile
+          if exists
+            then do removeFileSafe targetFile
+                    -- Big fat hairy race condition
+                    renameFile newFile targetFile
+                    -- If the removeFile succeeds and the renameFile fails
+                    -- then we've lost the atomic property.
+            else throwIOIO err
+#else
+      renameFile newFile targetFile
+#endif
+   `Exception.onException` do hClose newHandle
+                              removeFileSafe newFile
+  where
+    template = targetName <.> "tmp"
+    targetDir | null targetDir_ = "."
+              | otherwise       = targetDir_
+    --TODO: remove this when takeDirectory/splitFileName is fixed
+    --      to always return a valid dir
+    (targetDir_,targetName) = splitFileName targetFile
+
+openNewFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewFile dir template = do
+  -- this was added to System.IO in 6.12.1
+  -- we must use this version because the version below opens the file
+  -- in binary mode.
+  openTempFileWithDefaultPermissions dir template
+
+-- | The function splits the given string to substrings
+-- using 'isSearchPathSeparator'.
+parseSearchPath :: String -> [FilePath]
+parseSearchPath path = split path
+  where
+    split :: String -> [String]
+    split s =
+      case rest' of
+        []     -> [chunk]
+        _:rest -> chunk : split rest
+      where
+        chunk =
+          case chunk' of
+#ifdef mingw32_HOST_OS
+            ('\"':xs@(_:_)) | last xs == '\"' -> init xs
+#endif
+            _                                 -> chunk'
+
+        (chunk', rest') = break isSearchPathSeparator s
+
+readUTF8File :: FilePath -> IO String
+readUTF8File file = do
+  h <- openFile file ReadMode
+  -- fix the encoding to UTF-8
+  hSetEncoding h utf8
+  hGetContents h
+
+-- removeFileSave doesn't throw an exceptions, if the file is already deleted
+removeFileSafe :: FilePath -> IO ()
+removeFileSafe fn =
+  removeFile fn `catchIO` \ e ->
+    when (not $ isDoesNotExistError e) $ ioError e
+
+absolutePath :: FilePath -> IO FilePath
+absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
+
+-- | Only global packages may be marked as relocatable!
+--   May break horribly for general use, only reliable for Haste base packages.
+relocate :: [String] -> String -> Sh.Shell ()
+relocate packages pkg = do
+    pi <- Sh.run hastePkgBinary (packages ++ ["describe", pkg]) ""
+    Sh.run_ hastePkgBinary (packages ++ ["update", "-", "--force", "--global"])
+                           (reloc pi)
+  where
+    reloc = unlines . map fixPath . lines
+
+    fixPath s
+      | isKey "library-dirs: " s       = prefix s "library-dirs" importDir
+      | isKey "import-dirs: " s        = prefix s "import-dirs" importDir
+      | isKey "haddock-interfaces: " s = prefix s "haddock-interfaces" importDir
+      | isKey "haddock-html: " s       = prefix s "haddock-html" importDir
+      | isKey "include-dirs: " s       = "include-dirs: " ++ includeDir
+      | otherwise                      = s
+
+    prefix s pfx path = pfx ++ ": " ++ path </> stripPrefix s
+
+    stripPrefix s
+      | os == "darwin" =
+        case take 3 $ reverse $ splitPath s of
+          [third, second, first] -> first </> second </> third
+      | otherwise =
+        case take 2 $ reverse $ splitPath s of
+          [second, first] -> first </> second
+
+    isKey _ "" =
+      False
+    isKey key str =
+      and $ zipWith (==) key str
+
+    importDir
+      | os == "linux"  = "${pkgroot}" </> "libraries" </> "lib"
+      | otherwise      = "${pkgroot}" </> "libraries"
+    includeDir = "${pkgroot}" </> "include"