haste-compiler 0.5.1.3 → 0.5.2

raw patch · 22 files changed

+656/−726 lines, 22 filesdep ~shellmatePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: shellmate

API changes (from Hackage documentation)

Files

• haste-compiler.cabal +2/−3
• lib/Canvas.js +0/−24
• lib/jsstring.js +0/−48
• lib/rts.js +26/−0
• lib/stdlib.js +0/−194
• libraries/haste-lib/src/Haste.hs +30/−25
• libraries/haste-lib/src/Haste/Ajax.hs +27/−20
• libraries/haste-lib/src/Haste/DOM/Core.hs +61/−51
• libraries/haste-lib/src/Haste/DOM/JSString.hs +29/−35
• libraries/haste-lib/src/Haste/Events.hs +5/−1
• libraries/haste-lib/src/Haste/Events/KeyEvents.hs +1/−1
• libraries/haste-lib/src/Haste/Events/TouchEvents.hs +84/−0
• libraries/haste-lib/src/Haste/Graphics/Canvas.hs +113/−104
• libraries/haste-lib/src/Haste/JSON.hs +14/−19
• libraries/haste-lib/src/Haste/JSString.hs +92/−63
• src/Data/JSTarget/Optimize.hs +133/−124
• src/Data/JSTarget/Print.hs +3/−3
• src/Data/JSTarget/Traversal.hs +12/−4
• src/Haste/Config.hs +2/−2
• src/Haste/PrimOps.hs +19/−3
• src/Haste/Version.hs +1/−1
• src/haste-boot.hs +2/−1

@@ -1,5 +1,5 @@ Name:           haste-compiler-Version:        0.5.1.3+Version:        0.5.2 License:        BSD3 License-File:   LICENSE Synopsis:       Haskell To ECMAScript compiler@@ -37,13 +37,11 @@     unicode.js     cheap-unicode.js     debug.js-    Canvas.js     Handle.js     Weak.js     endian.js     floatdecode.js     jsflow.js-    jsstring.js     Foreign.js  extra-source-files:@@ -281,6 +279,7 @@         Haste.Events.Core         Haste.Events.KeyEvents         Haste.Events.MouseEvents+        Haste.Events.TouchEvents         Haste.GHCPaths         Haste.Hash         Haste.Prim.Any

@@ -1,24 +0,0 @@-// 2D Canvas drawing primitives.-function jsHasCtx2D(elem) {return !!elem.getContext;}-function jsGetCtx2D(elem) {return elem.getContext('2d');}-function jsBeginPath(ctx) {ctx.beginPath();}-function jsMoveTo(ctx, x, y) {ctx.moveTo(x, y);}-function jsLineTo(ctx, x, y) {ctx.lineTo(x, y);}-function jsStroke(ctx) {ctx.stroke();}-function jsFill(ctx) {ctx.fill();}-function jsRotate(ctx, radians) {ctx.rotate(radians);}-function jsTranslate(ctx, x, y) {ctx.translate(x, y);}-function jsScale(ctx, x, y) {ctx.scale(x, y);}-function jsPushState(ctx) {ctx.save();}-function jsPopState(ctx) {ctx.restore();}-function jsResetCanvas(el) {el.width = el.width;}-function jsDrawImage(ctx, img, x, y) {ctx.drawImage(img, x, y);}-function jsDrawImageClipped(ctx, img, x, y, cx, cy, cw, ch) {-    ctx.drawImage(img, cx, cy, cw, ch, x, y, cw, ch);-}-function jsDrawText(ctx, str, x, y) {ctx.fillText(str, x, y);}-function jsClip(ctx) {ctx.clip();}-function jsArc(ctx, x, y, radius, fromAngle, toAngle) {-    ctx.arc(x, y, radius, fromAngle, toAngle);-}-function jsCanvasToDataURL(el) {return el.toDataURL('image/png');}

@@ -1,48 +0,0 @@-/* 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;-}

@@ -324,3 +324,29 @@     i = (i & 0x33333333) + ((i >> 2) & 0x33333333);     return (((i + (i >> 4)) & 0x0F0F0F0F) * 0x01010101) >> 24; }++function __clz(bits, x) {+    x &= (Math.pow(2, bits)-1);+    if(x === 0) {+        return bits;+    } else {+        return bits - (1 + Math.floor(Math.log(x)/Math.LN2));+    }+}++// TODO: can probably be done much faster with arithmetic tricks like __clz+function __ctz(bits, x) {+    var y = 1;+    x &= (Math.pow(2, bits)-1);+    if(x === 0) {+        return bits;+    }+    for(var i = 0; i < bits; ++i) {+        if(y & x) {+            return i;+        } else {+            y <<= 1;+        }+    }+    return 0;+}

@@ -1,31 +1,3 @@-function jsAlert(val) {-    if(typeof alert != 'undefined') {-        alert(val);-    } else {-        print(val);-    }-}--function jsLog(val) {-    console.log(val);-}--function jsPrompt(str) {-    var val;-    if(typeof prompt != 'undefined') {-        val = prompt(str);-    } else {-        print(str);-        val = readline();-    }-    return val == undefined ? '' : val.toString();-}--function jsEval(str) {-    var x = eval(str);-    return x == undefined ? '' : x.toString();-}- function isNull(obj) {     return obj === null; }@@ -58,147 +30,6 @@ 	    posy - (e.currentTarget.offsetTop || 0)]; } -function jsGet(elem, prop) {-    return elem[prop].toString();-}--function jsSet(elem, prop, val) {-    elem[prop] = val;-}--function jsGetAttr(elem, prop) {-    if(elem.hasAttribute(prop)) {-        return elem.getAttribute(prop).toString();-    } else {-        return "";-    }-}--function jsSetAttr(elem, prop, val) {-    elem.setAttribute(prop, val);-}--function jsGetStyle(elem, prop) {-    return elem.style[prop].toString();-}--function jsSetStyle(elem, prop, val) {-    elem.style[prop] = val;-}--function jsKillChild(child, parent) {-    parent.removeChild(child);-}--function jsClearChildren(elem) {-    while(elem.hasChildNodes()){-        elem.removeChild(elem.lastChild);-    }-}--function jsFind(elem) {-    var e = document.getElementById(elem)-    if(e) {-        return [1,e];-    }-    return [0];-}--function jsElemsByClassName(cls) {-    var es = document.getElementsByClassName(cls);-    var els = [0];--    for (var i = es.length-1; i >= 0; --i) {-        els = [1, es[i], els];-    }-    return els;-}--function jsQuerySelectorAll(elem, query) {-    var els = [0], nl;--    if (!elem || typeof elem.querySelectorAll !== 'function') {-        return els;-    }--    nl = elem.querySelectorAll(query);--    for (var i = nl.length-1; i >= 0; --i) {-        els = [1, nl[i], els];-    }--    return els;-}--function jsCreateElem(tag) {-    return document.createElement(tag);-}--function jsCreateTextNode(str) {-    return document.createTextNode(str);-}--function jsGetChildBefore(elem) {-    elem = elem.previousSibling;-    while(elem) {-        if(typeof elem.tagName != 'undefined') {-            return [1,elem];-        }-        elem = elem.previousSibling;-    }-    return [0];-}--function jsGetLastChild(elem) {-    var len = elem.childNodes.length;-    for(var i = len-1; i >= 0; --i) {-        if(typeof elem.childNodes[i].tagName != 'undefined') {-            return [1,elem.childNodes[i]];-        }-    }-    return [0];-}---function jsGetFirstChild(elem) {-    var len = elem.childNodes.length;-    for(var i = 0; i < len; i++) {-        if(typeof elem.childNodes[i].tagName != 'undefined') {-            return [1,elem.childNodes[i]];-        }-    }-    return [0];-}---function jsGetChildren(elem) {-    var children = [0];-    var len = elem.childNodes.length;-    for(var i = len-1; i >= 0; --i) {-        if(typeof elem.childNodes[i].tagName != 'undefined') {-            children = [1, elem.childNodes[i], children];-        }-    }-    return children;-}--function jsSetChildren(elem, children) {-    children = E(children);-    jsClearChildren(elem, 0);-    while(children[0] === 1) {-        elem.appendChild(E(children[1]));-        children = E(children[2]);-    }-}--function jsAppendChild(child, container) {-    container.appendChild(child);-}--function jsAddChildBefore(child, container, after) {-    container.insertBefore(child, after);-}- var jsRand = Math.random;  // Concatenate a Haskell list of JS strings@@ -213,11 +44,6 @@     return arr.join(sep); } -// JSON stringify a string-function jsStringify(str) {-    return JSON.stringify(str);-}- // Parse a JSON message into a Haste.JSON.JSON value. // As this pokes around inside Haskell values, it'll need to be updated if: // * Haste.JSON.JSON changes;@@ -272,26 +98,6 @@         return [0];     }     return [1, toHS(arr[elem]), new T(function() {return arr2lst_json(arr,elem+1);}),true]-}--function ajaxReq(method, url, async, postdata, cb) {-    var xhr = new XMLHttpRequest();-    xhr.open(method, url, async);--    if(method == "POST") {-        xhr.setRequestHeader("Content-type",-                             "application/x-www-form-urlencoded");-    }-    xhr.onreadystatechange = function() {-        if(xhr.readyState == 4) {-            if(xhr.status == 200) {-                B(A(cb,[[1,xhr.responseText],0]));-            } else {-                B(A(cb,[[0],0])); // Nothing-            }-        }-    }-    xhr.send(postdata); }  /* gettimeofday(2) */

@@ -1,50 +1,55 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, CPP,-             OverloadedStrings #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, 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 (+    -- * Basic utility functions     JSString, JSAny, URL,     alert, prompt, eval, writeLog, catJSStr, fromJSStr,-    module Haste.Prim.JSType, module Haste.DOM.Core, module Haste.Timer,-    module Haste.Random, module Haste.Hash++    -- * URL hash handling+    onHashChange, onHashChange', setHash, getHash, setHash', getHash',++    -- * Random number generation (deprecated; use the @random@ package instead)+    Random (..), Seed, next, mkSeed, newSeed,++    -- * Timers+    Timer, Interval (..), setTimer, stopTimer,++    -- * Fast conversions for JS-native types+    JSType (..), JSNum (..), toString, fromString, convert   ) where import Haste.Prim import Haste.Timer import Haste.Random import Haste.Prim.JSType-import Haste.DOM.Core import Haste.Hash+import Haste.Foreign import Control.Monad.IO.Class -#ifdef __HASTE__-foreign import ccall jsAlert  :: JSString -> IO ()-foreign import ccall jsLog    :: JSString -> IO ()-foreign import ccall jsPrompt :: JSString -> IO JSString-foreign import ccall jsEval   :: JSString -> IO JSString+jsAlert :: String -> IO ()+jsAlert = ffi "alert" -#else-jsAlert  :: JSString -> IO ()-jsAlert = error "Tried to use jsAlert on server side!"-jsLog    :: JSString -> IO ()-jsLog = error "Tried to use jsLog on server side!"-jsPrompt :: JSString -> IO JSString-jsPrompt = error "Tried to use jsPrompt on server side!"-jsEval   :: JSString -> IO JSString-jsEval = error "Tried to use jsEval on server side!"-#endif+jsLog :: String -> IO ()+jsLog = ffi "(function(x){console.log(x);})" +jsPrompt :: String -> IO String+jsPrompt = ffi "(function(s){var x = prompt(s);\+\return (x === null) ? '' : x.toString();})"++jsEval :: JSString -> IO JSString+jsEval = ffi "(function(s){var x = eval(s);\+\return (typeof x === 'undefined') ? 'undefined' : x.toString();})"+ -- | Javascript alert() function. alert :: MonadIO m => String -> m ()-alert = liftIO . jsAlert . toJSStr+alert = liftIO . jsAlert  -- | Javascript prompt() function. prompt :: MonadIO m => String -> m String-prompt q = liftIO $ do-  a <- jsPrompt (toJSStr q)-  return (fromJSStr a)+prompt = liftIO . jsPrompt  -- | Javascript eval() function. eval :: MonadIO m => JSString -> m JSString@@ -52,4 +57,4 @@  -- | Use console.log to write a message. writeLog :: MonadIO m => String -> m ()-writeLog = liftIO . jsLog . toJSStr+writeLog = liftIO . jsLog

@@ -1,26 +1,38 @@-{-# LANGUAGE CPP                      #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings        #-}+{-# LANGUAGE OverloadedStrings #-} -- | Low level XMLHttpRequest support. IE6 and older are not supported. module Haste.Ajax (Method (..), URL, ajaxRequest, noParams) where+import Haste.Foreign import Haste.Prim import Haste.Prim.JSType import Control.Monad.IO.Class+import Control.Monad (join) -#ifdef __HASTE__-foreign import ccall ajaxReq :: JSString    -- method-                             -> JSString    -- url-                             -> Bool        -- async?-                             -> JSString    -- POST data-                             -> Ptr (Maybe JSString -> IO ())-                             -> IO ()-#else-ajaxReq :: JSString -> JSString -> Bool -> JSString -> Ptr (Maybe JSString -> IO ()) -> IO ()-ajaxReq = error "Tried to use ajaxReq in native code!"-#endif+ajaxReq :: Method   -- method (GET/POST)+        -> JSString -- URL+        -> Bool     -- async?+        -> JSString -- POST data+        -> (Maybe JSString -> IO ()) -- callback+        -> IO ()+ajaxReq = ffi "(function(method, url, async, postdata, cb) {\+    \var xhr = new XMLHttpRequest();\+    \xhr.open(method, url, async);\+    \if(method == 'POST') {\+        \xhr.setRequestHeader('Content-type',\+                             \'application/x-www-form-urlencoded');\+    \}\+    \xhr.onreadystatechange = function() {\+        \if(xhr.readyState == 4) {\+            \cb(xhr.status == 200 ? xhr.responseText : null);\+        \}\+    \};\+    \xhr.send(postdata);})"  data Method = GET | POST deriving Show +instance ToAny Method where+  toAny GET  = toAny ("GET" :: JSString)+  toAny POST = toAny ("POST" :: JSString)+ -- | Pass to 'ajaxRequest' instead of @[]@ when no parameters are needed, to --   avoid type ambiguity errors. noParams :: [((), ())]@@ -35,14 +47,9 @@             -> (Maybe c -> IO ()) -- ^ Callback to invoke on completion.             -> m () ajaxRequest m url kv cb = liftIO $ do-    _ <- ajaxReq (showm m) url' True pd cb'+    _ <- ajaxReq m url' True pd (cb . join . fmap fromJSString)     return ()   where-    showm GET  = "GET"-    showm POST = "POST"-    cb' = toPtr $ cb . fromJSS-    fromJSS (Just jss) = fromJSString jss-    fromJSS _          = Nothing     url' = case m of            GET              | null kv   -> toJSString url

@@ -1,5 +1,4 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving,-             OverloadedStrings #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-} -- | Core types and operations for DOM manipulation. module Haste.DOM.Core (     Elem (..), IsElem (..), Attribute, AttrName (..),@@ -10,6 +9,8 @@     setChildren, getChildren,     getLastChild, getFirstChild, getChildBefore,     insertChildBefore, appendChild,+    -- Low level stuff+    jsSet, jsSetAttr, jsSetStyle,     -- Deprecated     removeChild, addChild, addChildBefore   ) where@@ -18,45 +19,57 @@ 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!"+jsSet = ffi "(function(e,p,v){e[p] = v;})"+ jsSetAttr :: Elem -> JSString -> JSString -> IO ()-jsSetAttr = error "Tried to use jsSetAttr on server side!"+jsSetAttr = ffi "(function(e,p,v){e.setAttribute(p, v);})"+ jsSetStyle :: Elem -> JSString -> JSString -> IO ()-jsSetStyle = error "Tried to use jsSetStyle on server side!"+jsSetStyle = ffi "(function(e,p,v){e.style[p] = v;})"+ 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!"+jsAppendChild = ffi "(function(c,p){p.appendChild(c);})"++jsGetFirstChild :: Elem -> IO (Maybe Elem)+jsGetFirstChild = ffi "(function(e){\+for(e = e.firstChild; e != null; e = e.nextSibling)\+  {if(e instanceof HTMLElement) {return e;}}\+return null;})"++jsGetLastChild :: Elem -> IO (Maybe Elem)+jsGetLastChild = ffi "(function(e){\+for(e = e.lastChild; e != null; e = e.previousSibling)\+  {if(e instanceof HTMLElement) {return e;}}\+return null;})"++jsGetChildren :: Elem -> IO [Elem]+jsGetChildren = ffi "(function(e){\+var ch = [];\+for(e = e.firstChild; e != null; e = e.nextSibling)\+  {if(e instanceof HTMLElement) {ch.push(e);}}\+return ch;})"++jsSetChildren :: Elem -> [Elem] -> IO ()+jsSetChildren = ffi "(function(e,ch){\+while(e.firstChild) {e.removeChild(e.firstChild);}\+for(var i in ch) {e.appendChild(ch[i]);}})"+ 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!"+jsAddChildBefore = ffi "(function(c,p,a){p.insertBefore(c,a);})"++jsGetChildBefore :: Elem -> IO (Maybe Elem)+jsGetChildBefore = ffi "(function(e){\+for(; e != null; e = e.previousSibling)\+  {if(e instanceof HTMLElement) {return e;}\+return null;})"+ jsKillChild :: Elem -> Elem -> IO ()-jsKillChild = error "Tried to use jsKillChild on server side!"+jsKillChild = ffi "(function(c,p){p.removeChild(c);})"+ jsClearChildren :: Elem -> IO ()-jsClearChildren = error "Tried to use jsClearChildren on server side!"-#endif+jsClearChildren = ffi "(function(e){\+while(e.firstChild){e.removeChild(e.firstChild);}})"  -- | A DOM node. newtype Elem = Elem JSAny@@ -128,27 +141,24 @@ -- | 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();})" +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();})" +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();})" +blur' :: Elem -> IO ()+blur' = ffi "(function(e) {e.blur();})"+ -- | The DOM node corresponding to document. document :: Elem document = constant "document"@@ -187,19 +197,19 @@  -- | 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)+getChildBefore e = liftIO $ 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)+getFirstChild e = liftIO $ 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)+getLastChild e = liftIO $ 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)+getChildren e = liftIO $ jsGetChildren (elemOf e)  -- | Clear the given element's list of children, and append all given children --   to it.@@ -207,7 +217,7 @@             => parent             -> [child]             -> m ()-setChildren e ch = liftIO $ jsSetChildren (elemOf e) (toPtr $ map elemOf ch)+setChildren e ch = liftIO $ jsSetChildren (elemOf e) (map elemOf ch)  -- | Remove all children from the given element. clearChildren :: (IsElem e, MonadIO m) => e -> m ()

@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP #-}+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} -- | DOM manipulation functions using 'JSString' for string representation. module Haste.DOM.JSString (     -- From Haste.DOM.Core@@ -32,42 +32,36 @@ 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!"+jsGet = ffi "(function(e,p){return e[p].toString();})"+ 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!"+jsGetAttr = ffi "(function(e,p){\+\return e.hasAttribute(p) ? e.getAttribute(p) : '';})"+ 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!"+jsGetStyle = ffi "(function(e,p){return e.style[p].toString();})"++jsFind :: JSString -> IO (Maybe Elem)+jsFind = ffi "(function(id){return document.getElementById(id);})"++jsQuerySelectorAll :: Elem -> JSString -> IO [Elem]+jsQuerySelectorAll = ffi "(function(e,q){\+  \if(!e || typeof e.querySelectorAll !== 'function') {\+    \return [];\+  \} else {\+    \return e.querySelectorAll(q);\+  \}})"++jsElemsByClassName :: JSString -> IO [Elem]+jsElemsByClassName = ffi "(function(c){\+\return document.getElementsByClassName(e);})"+ jsCreateElem :: JSString -> IO Elem-jsCreateElem = error "Tried to use jsCreateElem on server side!"+jsCreateElem = ffi "(function(t){return document.createElement(t);})"+ jsCreateTextNode :: JSString -> IO Elem-jsCreateTextNode = error "Tried to use jsCreateTextNode on server side!"-#endif+jsCreateTextNode = ffi "(function(s){return document.createTextNode(s);})"  -- | Create a style attribute name. style :: JSString -> AttrName@@ -125,15 +119,15 @@  -- | Get an element by its HTML ID attribute. elemById :: MonadIO m => ElemID -> m (Maybe Elem)-elemById eid = liftIO $ fromPtr `fmap` (jsFind eid)+elemById eid = liftIO $ jsFind eid  -- | Get all elements of the given class. elemsByClass :: MonadIO m => ElemClass -> m [Elem]-elemsByClass cls = liftIO $ fromPtr `fmap` (jsElemsByClassName cls)+elemsByClass cls = liftIO $ 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)+elemsByQS el sel = liftIO $ jsQuerySelectorAll (elemOf el) sel  -- | Perform an IO action on an element. withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a

@@ -12,9 +12,13 @@     KeyEvent (..), KeyData (..), mkKeyData,      -- * Mouse-related events-    MouseEvent (..), MouseData (..), MouseButton (..)+    MouseEvent (..), MouseData (..), MouseButton (..),++    -- * Touch-related events+    TouchEvent (..), TouchData (..), Touch (..)   ) 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+import Haste.Events.TouchEvents as TouchEvents

@@ -27,7 +27,7 @@     keyMeta  = False   } --- | Num instance for KeyData to enable pattern matching against numeric+-- | Num instance for 'KeyData' to enable pattern matching against numeric --   key codes. instance Num KeyData where   fromInteger = mkKeyData . fromInteger

@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-}+-- | Events relating to touch input.+module Haste.Events.TouchEvents (+    TouchEvent (..), TouchData (..), Touch (..)+  ) where+import Haste.Prim.Any+import Haste.Foreign+import Haste.Events.Core+import Haste.DOM.Core+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++data TouchEvent+  = TouchStart+  | TouchMove+  | TouchEnd+  | TouchCancel++-- | Event data for touch events.+data TouchData = TouchData {+    -- | All fingers currently on the screen.+    touches        :: [Touch],++    -- | All fingers on the DOM element receiving the event.+    targetTouches  :: [Touch],++    -- | All fingers involved in the current event. For instance, fingers+    --   removed for the 'TouchEnd' event.+    changedTouches :: [Touch]+  }++-- | A finger touching the screen.+data Touch = Touch {+    -- | Unique identifier for this touch.+    identifier    :: !Int,++    -- | Target element of the touch.+    target        :: !Elem,++    -- | Page coordinates of the touch, including scroll offsets.+    pageCoords    :: !(Int, Int),++    -- | Page coordinates of the touch, excluding scroll offsets.+    clientCoords  :: !(Int, Int),++    -- | Screen coordinates of the touch.+    screenCoords  :: !(Int, Int)+  }++instance FromAny Touch where+  fromAny t =+    Touch <$> get t "identifier"+          <*> get t "target"+          <*> ((,) <$> get t "pageX"   <*> get t "pageY")+          <*> ((,) <$> get t "clientX" <*> get t "clientY")+          <*> ((,) <$> get t "screenX" <*> get t "screenY")++instance Event TouchEvent where+  type EventData TouchEvent = TouchData+  eventName TouchStart  = "touchstart"+  eventName TouchMove   = "touchmove"+  eventName TouchEnd    = "touchend"+  eventName TouchCancel = "touchcancel"++  eventData _ e = do+    ts <- get e "touches"+    (cts, tts) <- getTIDs e+    return $ TouchData {+        touches = ts,+        changedTouches = filter ((`elem` cts) . identifier) ts,+        targetTouches = filter ((`elem` tts) . identifier) ts+      }++-- | Get the touch IDs of all touches for changedTouches and targetTouches.+getTIDs :: JSAny -> IO ([Int], [Int])+getTIDs = ffi "(function(e) {\+  var len = e.changedTouches.length;\+  var chts = new Array(len);\+  for(var i = 0; i < len; ++i) {chts[i] = e.changedTouches[i].identifier;}\+  var len = e.targetTouches.length;\+  var tts = new Array(len);\+  for(var i = 0; i < len; ++i) {tts[i] = e.targetTouches[i].identifier;}\+  return [chts, tts];})"

@@ -1,30 +1,33 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings,-             TypeSynonymInstances, FlexibleInstances, GADTs, CPP,-             GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances,+             GADTs, CPP, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- | Basic Canvas graphics library. module Haste.Graphics.Canvas (-  -- Types-  Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..),-  Ctx, AnyImageBuffer (..),-  -- Classes-  ImageBuffer (..), BitmapSource (..),-  -- Obtaining a canvas for drawing-  getCanvasById, getCanvas, createCanvas,-  -- Rendering pictures, extracting data from a canvas-  render, renderOnTop, buffer, toDataURL,-  -- Working with colors and opacity-  setStrokeColor, setFillColor, color, opacity, lineWidth,-  -- Matrix operations-  translate, scale, rotate,-  -- Using shapes-  stroke, fill, clip,-  -- Creating shapes-  line, path, rect, circle, arc,-  -- Working with text-  font, text,-  -- Extending the library-  withContext+    -- * Basic types and classes+    Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..),+    Ctx, AnyImageBuffer (..),+    ImageBuffer (..), BitmapSource (..),++    -- *  Obtaining a canvas+    getCanvasById, getCanvas, createCanvas,++    -- * Rendering and reading canvases+    render, renderOnTop, buffer, toDataURL,++    -- * Colors and opacity+    setStrokeColor, setFillColor, color, opacity,++    -- * Matrix operations+    translate, scale, rotate,+    -- * Drawing shapes+    stroke, fill, clip,+    lineWidth, line, path, rect, circle, arc,++    -- * Rendering text+    font, text,++    -- * Extending the library+    withContext   ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative@@ -32,82 +35,81 @@ import Control.Monad.IO.Class import Data.Maybe (fromJust) import Haste-import qualified Haste.DOM.JSString as J+import Haste.DOM.JSString+import Haste.DOM.Core import Haste.Concurrent (CIO) -- for SPECIALISE pragma-import Haste.Foreign (ToAny (..), FromAny (..))-#ifdef __HASTE__-import Haste.Prim (JSString (..), JSAny (..))-#endif+import Haste.Foreign (ToAny (..), FromAny (..), ffi) -#ifdef __HASTE__-foreign import ccall jsHasCtx2D :: Elem -> IO Bool-foreign import ccall jsGetCtx2D :: Elem -> IO Ctx-foreign import ccall jsBeginPath :: Ctx -> IO ()-foreign import ccall jsMoveTo :: Ctx -> Double -> Double -> IO ()-foreign import ccall jsLineTo :: Ctx -> Double -> Double -> IO ()-foreign import ccall jsStroke :: Ctx -> IO ()-foreign import ccall jsFill :: Ctx -> IO ()-foreign import ccall jsRotate :: Ctx -> Double -> IO ()-foreign import ccall jsTranslate :: Ctx -> Double -> Double -> IO ()-foreign import ccall jsScale :: Ctx -> Double -> Double -> IO ()-foreign import ccall jsPushState :: Ctx -> IO ()-foreign import ccall jsPopState :: Ctx -> IO ()-foreign import ccall jsResetCanvas :: Elem -> IO ()-foreign import ccall jsDrawImage :: Ctx -> Elem -> Double -> Double -> IO ()-foreign import ccall jsDrawImageClipped :: Ctx -> Elem-                                        -> Double -> Double-                                        -> Double -> Double -> Double -> Double -                                        -> IO ()-foreign import ccall jsDrawText :: Ctx -> JSString -> Double -> Double -> IO ()-foreign import ccall jsClip :: Ctx -> IO ()-foreign import ccall jsArc :: Ctx-                           -> Double -> Double-                           -> Double-                           -> Double -> Double-                           -> IO ()-foreign import ccall jsCanvasToDataURL :: Elem -> IO JSString-#else jsHasCtx2D :: Elem -> IO Bool+jsHasCtx2D = ffi "(function(e){return !!e.getContext;})"+ jsGetCtx2D :: Elem -> IO Ctx+jsGetCtx2D = ffi "(function(e){return e.getContext('2d');})"+ jsBeginPath :: Ctx -> IO ()+jsBeginPath = ffi "(function(ctx){ctx.beginPath();})"+ jsMoveTo :: Ctx -> Double -> Double -> IO ()+jsMoveTo = ffi "(function(ctx,x,y){ctx.moveTo(x,y);})"+ jsLineTo :: Ctx -> Double -> Double -> IO ()+jsLineTo = ffi "(function(ctx,x,y){ctx.lineTo(x,y);})"+ jsStroke :: Ctx -> IO ()+jsStroke = ffi "(function(ctx){ctx.stroke();})"+ jsFill :: Ctx -> IO ()+jsFill = ffi "(function(ctx){ctx.fill();})"+ jsRotate :: Ctx -> Double -> IO ()+jsRotate = ffi "(function(ctx,rad){ctx.rotate(rad);})"+ jsTranslate :: Ctx -> Double -> Double -> IO ()+jsTranslate = ffi "(function(ctx,x,y){ctx.translate(x,y);})"+ jsScale :: Ctx -> Double -> Double -> IO ()+jsScale = ffi "(function(ctx,x,y){ctx.scale(x,y);})"+ jsPushState :: Ctx -> IO ()+jsPushState = ffi "(function(ctx){ctx.save();})"+ jsPopState :: Ctx -> IO ()+jsPopState = ffi "(function(ctx){ctx.restore();})"+ jsResetCanvas :: Elem -> IO ()+jsResetCanvas = ffi "(function(e){e.width = e.width;})"+ jsDrawImage :: Ctx -> Elem -> Double -> Double -> IO ()-jsDrawImageClipped :: Ctx -> Elem -> Double -> Double-                                  -> Double -> Double -> Double -> Double -                                  -> IO ()+jsDrawImage = ffi "(function(ctx,i,x,y){ctx.drawImage(i,x,y);})"++jsDrawImageClipped :: Ctx -> Elem+                                        -> Double -> Double+                                        -> Double -> Double -> Double -> Double +                                        -> IO ()+jsDrawImageClipped = ffi "(function(ctx, img, x, y, cx, cy, cw, ch){\+ctx.drawImage(img, cx, cy, cw, ch, x, y, cw, ch);})"++jsDrawImageScaled :: Ctx -> Elem+                                        -> Double -> Double -> Double -> Double+                                        -> IO ()+jsDrawImageScaled = ffi "(function(ctx, img, x, y, w, h){\+ctx.drawImage(img, x, y, w, h);})"+ jsDrawText :: Ctx -> JSString -> Double -> Double -> IO ()+jsDrawText = ffi "(function(ctx,s,x,y){ctx.fillText(s,x,y);})"+ jsClip :: Ctx -> IO ()-jsArc :: Ctx -> Double -> Double -> Double -> Double -> Double -> IO ()+jsClip = ffi "(function(ctx){ctx.clip();})"++jsArc :: Ctx -> Double -> Double+             -> Double+             -> Double -> Double+             -> IO ()+jsArc = ffi "(function(ctx, x, y, radius, fromAngle, toAngle){\+ctx.arc(x, y, radius, fromAngle, toAngle);})"+ jsCanvasToDataURL :: Elem -> IO JSString-jsHasCtx2D = error "Tried to use Canvas in native code!"-jsGetCtx2D = error "Tried to use Canvas in native code!"-jsBeginPath = error "Tried to use Canvas in native code!"-jsMoveTo = error "Tried to use Canvas in native code!"-jsLineTo = error "Tried to use Canvas in native code!"-jsStroke = error "Tried to use Canvas in native code!"-jsFill = error "Tried to use Canvas in native code!"-jsRotate = error "Tried to use Canvas in native code!"-jsTranslate = error "Tried to use Canvas in native code!"-jsScale = error "Tried to use Canvas in native code!"-jsPushState = error "Tried to use Canvas in native code!"-jsPopState = error "Tried to use Canvas in native code!"-jsResetCanvas = error "Tried to use Canvas in native code!"-jsDrawImage = error "Tried to use Canvas in native code!"-jsDrawImageClipped = error "Tried to use Canvas in native code!"-jsDrawText = error "Tried to use Canvas in native code!"-jsClip = error "Tried to use Canvas in native code!"-jsArc = error "Tried to use Canvas in native code!"-jsCanvasToDataURL = error "Tried to use Canvas in native code!"-#endif+jsCanvasToDataURL = ffi "(function(e){return e.toDataURL('image/png');})"  -- | A bitmap, backed by an IMG element. --   JS representation is a reference to the backing IMG element.@@ -121,16 +123,22 @@   -- | Draw a portion of the image buffer with its top left corner at the   --   specified point.   drawClipped :: a -> Point -> Rect -> Picture ()+  -- | Draw the image buffer within given rectangle.+  drawScaled :: a -> Rect -> Picture ()  instance ImageBuffer Canvas where   draw (Canvas _ buf) (x, y) = Picture $ \ctx -> jsDrawImage ctx buf x y   drawClipped (Canvas _ buf) (x, y) (Rect cx cy cw ch) = Picture $ \ctx ->     jsDrawImageClipped ctx buf x y cx cy cw ch+  drawScaled (Canvas _ buf) (Rect x y w h) = Picture $ \ctx ->+    jsDrawImageScaled ctx buf x y w h  instance ImageBuffer Bitmap where   draw (Bitmap buf) (x, y) = Picture $ \ctx -> jsDrawImage ctx buf x y   drawClipped (Bitmap buf) (x, y) (Rect cx cy cw ch) = Picture $ \ctx ->     jsDrawImageClipped ctx buf x y cx cy cw ch+  drawScaled (Bitmap buf) (Rect x y w h) = Picture $ \ctx ->+    jsDrawImageScaled ctx buf x y w h  -- | Any type that can be used to obtain a bitmap. class BitmapSource src where@@ -139,8 +147,8 @@  instance BitmapSource URL where   loadBitmap url = liftIO $ do-    img <- J.newElem "img"-    J.setProp img "src" (toJSString url)+    img <- newElem "img"+    setProp img "src" (toJSString url)     loadBitmap img  instance BitmapSource Elem where@@ -152,6 +160,7 @@ instance ImageBuffer AnyImageBuffer where   draw (AnyImageBuffer buf) = draw buf   drawClipped (AnyImageBuffer buf) = drawClipped buf+  drawScaled (AnyImageBuffer buf) = drawScaled buf  instance IsElem Canvas where   elemOf (Canvas _ctx e) = e@@ -255,7 +264,7 @@ -- | Create a 2D drawing context from a DOM element identified by its ID. getCanvasById :: MonadIO m => String -> m (Maybe Canvas) getCanvasById eid = liftIO $ do-  e <- J.elemById (toJSString eid)+  e <- elemById (toJSString eid)   maybe (return Nothing) getCanvas e  -- | Create a 2D drawing context from a DOM element.@@ -271,9 +280,9 @@ -- | Create an off-screen buffer of the specified size. createCanvas :: Int -> Int -> IO Canvas createCanvas w h = do-  buf <- J.newElem "canvas"-  J.setProp buf "width" (toJSString w)-  J.setProp buf "height" (toJSString h)+  buf <- newElem "canvas"+  setProp buf "width" (toJSString w)+  setProp buf "height" (toJSString h)   fromJust <$> getCanvas buf  -- | Clear a canvas, then draw a picture onto it.@@ -311,42 +320,42 @@ -- | Set a new color for strokes. setStrokeColor :: Color -> Picture () setStrokeColor c = Picture $ \(Ctx ctx) -> do-  J.setProp (Elem ctx) "strokeStyle" (color2JSString c)+  setProp (Elem ctx) "strokeStyle" (color2JSString c)  -- | Set a new fill color. setFillColor :: Color -> Picture () setFillColor c = Picture $ \(Ctx ctx) -> do-  J.setProp (Elem ctx) "fillStyle" (color2JSString c)+  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' <- J.getProp (Elem ctx) "globalAlpha"-  J.setProp (Elem ctx) "globalAlpha" (toJSString alpha)+  alpha' <- getProp (Elem ctx) "globalAlpha"+  setProp (Elem ctx) "globalAlpha" (toJSString alpha)   pict (Ctx ctx)-  J.setProp (Elem ctx) "globalAlpha" alpha'+  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 <- J.getProp (Elem ctx) "fillStyle"-    sc <- J.getProp (Elem ctx) "strokeStyle"-    J.setProp (Elem ctx) "fillStyle" c'-    J.setProp (Elem ctx) "strokeStyle" c'+    fc <- getProp (Elem ctx) "fillStyle"+    sc <- getProp (Elem ctx) "strokeStyle"+    setProp (Elem ctx) "fillStyle" c'+    setProp (Elem ctx) "strokeStyle" c'     pict (Ctx ctx)-    J.setProp (Elem ctx) "fillStyle" fc-    J.setProp (Elem ctx) "strokeStyle" sc+    setProp (Elem ctx) "fillStyle" fc+    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 <- J.getProp (Elem ctx) "lineWidth"-  J.setProp (Elem ctx) "lineWidth" (toJSString w)+  lw <- getProp (Elem ctx) "lineWidth"+  setProp (Elem ctx) "lineWidth" (toJSString w)   pict (Ctx ctx)-  J.setProp (Elem ctx) "lineWidth" lw+  setProp (Elem ctx) "lineWidth" lw  -- | Draw the specified picture using the given point as the origin. translate :: Vector -> Picture () -> Picture ()@@ -433,10 +442,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' <- J.getProp (Elem ctx) "font"-  J.setProp (Elem ctx) "font" (toJSString f)+  f' <- getProp (Elem ctx) "font"+  setProp (Elem ctx) "font" (toJSString f)   pict (Ctx ctx)-  J.setProp (Elem ctx) "font" f'+  setProp (Elem ctx) "font" f'  -- | Draw some text onto the canvas. text :: Point -> String -> Picture ()

@@ -18,25 +18,18 @@ import Control.Applicative #endif import Haste.Parsing-#else-import System.IO.Unsafe-import Haste.Foreign hiding (toObject) #endif+import Haste.Foreign hiding (toObject) --- | Create a Javascript object from a JSON object. Only makes sense in a+-- | Create a JavaScript object from a JSON object. Only makes sense in a --   browser context, obviously. toObject :: JSON -> JSAny-#ifdef __HASTE__ toObject = jsJSONParse . encodeJSON jsJSONParse :: JSString -> JSAny-jsJSONParse = unsafePerformIO . go-  where-    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+jsJSONParse = veryUnsafePerformIO . _jsJSONParse +_jsJSONParse :: JSString -> IO JSAny+_jsJSONParse = ffi "JSON.parse"  -- Remember to update jsParseJSON if this data type changes! data JSON@@ -60,7 +53,7 @@ numFail :: a numFail = error "Num JSON: not a numeric JSON node!" --- | This instance may be a bad idea, but it's nice to be able to create JSOn+-- | This instance may be a bad idea, but it's nice to be able to create JSON --   objects using plain numeric literals. instance Num JSON where   (Num a) + (Num b) = Num (a+b)@@ -79,14 +72,15 @@  #ifdef __HASTE__ foreign import ccall "jsShow" jsShowD :: Double -> JSString-foreign import ccall "jsStringify" jsStringify :: JSString -> JSString foreign import ccall "jsParseJSON" jsParseJSON :: JSString -> Ptr (Maybe JSON)+jsStringify :: JSString -> IO JSString+jsStringify = ffi "JSON.stringify" #else jsShowD :: Double -> JSString jsShowD = toJSStr . show -jsStringify :: JSString -> JSString-jsStringify = toJSStr . ('"' :) . unq . fromJSStr+jsStringify :: JSString -> IO JSString+jsStringify = return . toJSStr . ('"' :) . unq . fromJSStr   where     unq ('"' : cs) = "\\\"" ++ unq cs     unq (c : cs)@@ -132,7 +126,7 @@     false   = "false"     null    = "null"     enc acc Null         = null : acc-    enc acc (Str s)      = jsStringify s : acc+    enc acc (Str s)      = veryUnsafePerformIO (jsStringify s) : acc     enc acc (Num d)      = jsShowD d : acc     enc acc (Bool True)  = true : acc     enc acc (Bool False) = false : acc@@ -144,8 +138,9 @@     enc acc (Dict elems)       | ((key,val):xs) <- elems =         let encElem (k, v) a = comma : quote : k : quote : colon : enc a v-            encAll = opencu : jsStringify key : colon : encRest-            encRest  = enc (foldr encElem (closecu:acc) xs) val+            encAll =+              opencu : veryUnsafePerformIO (jsStringify key) : colon : encRest+            encRest = enc (foldr encElem (closecu:acc) xs) val         in encAll       | otherwise =         opencu : closecu : acc

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface, CPP, MagicHash #-}+{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface, CPP, MagicHash,+             GeneralizedNewtypeDeriving #-} -- | JSString standard functions, to make them a more viable alternative to --   the horribly inefficient standard Strings. --@@ -11,15 +12,15 @@ --   JavaScript's native regular expressions and thus only supported on the --   client. module Haste.JSString (-    -- | Building JSStrings+    -- * Building JSStrings     empty, singleton, pack, cons, snoc, append, replicate,-    -- | Deconstructing JSStrings+    -- * Deconstructing JSStrings     unpack, head, last, tail, drop, take, init, splitAt,-    -- | Examining JSStrings+    -- * Examining JSStrings     null, length, any, all,-    -- | Modifying JSStrings+    -- * Modifying JSStrings     map, reverse, intercalate, foldl', foldr, concat, concatMap,-    -- | Regular expressions (client-side only)+    -- * Regular expressions (client-side only)     RegEx, match, matches, regex, replace   ) where import qualified Data.List@@ -38,27 +39,54 @@ 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]+_jss_singleton :: Char -> IO JSString+_jss_singleton = ffi "String.fromCharCode" +_jss_cons :: Char -> JSString -> IO JSString+_jss_cons = ffi "(function(c,s){return String.fromCharCode(c)+s;})"++_jss_snoc :: JSString -> Char -> IO JSString+_jss_snoc = ffi "(function(s,c){return s+String.fromCharCode(c);})"++_jss_append :: JSString -> JSString -> IO JSString+_jss_append = ffi "(function(a,b){return a+b;})"++_jss_len :: JSString -> IO Int+_jss_len = ffi "(function(s){return s.length;})"++_jss_index :: JSString -> Int -> IO Double+_jss_index = ffi "(function(s,i){return s.charCodeAt(i);})"++_jss_substr :: JSString -> Int -> IO JSString+_jss_substr = ffi "(function(s,x){return s.substr(x);})"++_jss_take :: Int -> JSString -> IO JSString+_jss_take = ffi "(function(n,s){return s.substr(0,n);})"++_jss_rev :: JSString -> IO JSString+_jss_rev = ffi "(function(s){return s.split('').reverse().join('');})"++_jss_re_match :: JSString -> RegEx -> IO Bool+_jss_re_match = ffi "(function(s,re){return s.search(re)>=0;})"++_jss_re_compile :: JSString -> JSString -> IO RegEx+_jss_re_compile = ffi "(function(re,fs){return new RegExp(re,fs);})"++_jss_re_replace :: JSString -> RegEx -> JSString -> IO JSString+_jss_re_replace = ffi "(function(s,re,rep){return s.replace(re,rep);})"++_jss_re_find :: RegEx -> JSString -> IO [JSString]+_jss_re_find = ffi "(function(re,s) {\+var a = s.match(re);\+return a ? a : [];})"+ {-# INLINE _jss_map #-} _jss_map :: (Char -> Char) -> JSString -> JSString-_jss_map f = _jss_cmap (_jss_singleton . f)+_jss_map f s = veryUnsafePerformIO $ cmap_js (_jss_singleton . f) s  {-# INLINE _jss_cmap #-} _jss_cmap :: (Char -> JSString) -> JSString -> JSString-_jss_cmap f s = unsafePerformIO $ cmap_js (return . f) s+_jss_cmap f s = veryUnsafePerformIO $ cmap_js (return . f) s  cmap_js :: (Char -> IO JSString) -> JSString -> IO JSString cmap_js = ffi "(function(f,s){\@@ -104,29 +132,29 @@ d2c :: Char -> Char d2c = id -_jss_singleton :: Char -> JSString-_jss_singleton c = toJSStr [c]+_jss_singleton :: Char -> IO JSString+_jss_singleton c = return $ toJSStr [c] -_jss_cons :: Char -> JSString -> JSString-_jss_cons c s = toJSStr (c : fromJSStr s)+_jss_cons :: Char -> JSString -> IO JSString+_jss_cons c s = return $ toJSStr (c : fromJSStr s) -_jss_snoc :: JSString -> Char -> JSString-_jss_snoc s c = toJSStr (fromJSStr s ++ [c])+_jss_snoc :: JSString -> Char -> IO JSString+_jss_snoc s c = return $ toJSStr (fromJSStr s ++ [c]) -_jss_append :: JSString -> JSString -> JSString-_jss_append a b = catJSStr "" [a, b]+_jss_append :: JSString -> JSString -> IO JSString+_jss_append a b = return $ catJSStr "" [a, b] -_jss_len :: JSString -> Int-_jss_len s = Data.List.length $ fromJSStr s+_jss_len :: JSString -> IO Int+_jss_len s = return $ Data.List.length $ fromJSStr s -_jss_index :: JSString -> Int -> Char-_jss_index s n = fromJSStr s !! n+_jss_index :: JSString -> Int -> IO Char+_jss_index s n = return $ fromJSStr s !! n -_jss_substr :: JSString -> Int -> JSString-_jss_substr s n = toJSStr $ Data.List.drop n $ fromJSStr s+_jss_substr :: JSString -> Int -> IO JSString+_jss_substr s n = return $ toJSStr $ Data.List.drop n $ fromJSStr s -_jss_take :: Int -> JSString -> JSString-_jss_take n = toJSStr . Data.List.take n . fromJSStr+_jss_take :: Int -> JSString -> IO JSString+_jss_take n = return . toJSStr . Data.List.take n . fromJSStr  _jss_map :: (Char -> Char) -> JSString -> JSString _jss_map f = toJSStr . Data.List.map f . fromJSStr@@ -135,8 +163,8 @@ _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_rev :: JSString -> IO JSString+_jss_rev = return . toJSStr . Data.List.reverse . fromJSStr  _jss_foldl :: (a -> Char -> a) -> a -> JSString -> a _jss_foldl f x = Data.List.foldl' f x . fromJSStr@@ -144,19 +172,19 @@ _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 :: JSString -> JSString -> IO RegEx _jss_re_compile _ _ =   error "Regular expressions are only supported client-side!" -_jss_re_match :: JSString -> RegEx -> Bool+_jss_re_match :: JSString -> RegEx -> IO Bool _jss_re_match _ _ =   error "Regular expressions are only supported client-side!" -_jss_re_replace :: JSString -> RegEx -> JSString -> JSString+_jss_re_replace :: JSString -> RegEx -> JSString -> IO JSString _jss_re_replace _ _ _ =   error "Regular expressions are only supported client-side!" -_jss_re_find :: RegEx -> JSString -> Ptr [JSString]+_jss_re_find :: RegEx -> JSString -> IO [JSString] _jss_re_find _ _ =   error "Regular expressions are only supported client-side!" @@ -164,9 +192,10 @@  -- | A regular expression. May be used to match and replace JSStrings. newtype RegEx = RegEx JSAny+  deriving (ToAny, FromAny)  instance IsString RegEx where-  fromString s = _jss_re_compile (fromString s) ""+  fromString s = veryUnsafePerformIO $ _jss_re_compile (fromString s) ""  -- | O(1) The empty JSString. empty :: JSString@@ -174,7 +203,7 @@  -- | O(1) JSString consisting of a single character. singleton :: Char -> JSString-singleton = _jss_singleton+singleton = veryUnsafePerformIO . _jss_singleton  -- | O(n) Convert a list of Char into a JSString. pack :: [Char] -> JSString@@ -187,22 +216,22 @@ infixr 5 `cons` -- | O(n) Prepend a character to a JSString. cons :: Char -> JSString -> JSString-cons = _jss_cons+cons c s = veryUnsafePerformIO $ _jss_cons c s  infixl 5 `snoc` -- | O(n) Append a character to a JSString. snoc :: JSString -> Char -> JSString-snoc = _jss_snoc+snoc s c = veryUnsafePerformIO $ _jss_snoc s c  -- | O(n) Append two JSStrings. append :: JSString -> JSString -> JSString-append = _jss_append+append a b = veryUnsafePerformIO $ _jss_append a b  -- | O(1) Extract the first element of a non-empty JSString. head :: JSString -> Char head s = #ifdef __HASTE__-  case _jss_index s 0 of+  case veryUnsafePerformIO $ _jss_index s 0 of     c | isNaN c   -> error "Haste.JSString.head: empty JSString"       | otherwise -> d2c c -- Double/Int/Char share representation. #else@@ -212,43 +241,43 @@ -- | O(1) Extract the last element of a non-empty JSString. last :: JSString -> Char last s =-  case _jss_len s of+  case veryUnsafePerformIO $ _jss_len s of     0 -> error "Haste.JSString.head: empty JSString"-    n -> d2c (_jss_index s (n-1))+    n -> d2c (veryUnsafePerformIO $ _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+tail s = veryUnsafePerformIO $ _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)+drop n s = veryUnsafePerformIO $ _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+take n s = veryUnsafePerformIO $ _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+init s = veryUnsafePerformIO $ _jss_take (veryUnsafePerformIO (_jss_len s)-1) s  -- | O(1) Test whether a JSString is empty. null :: JSString -> Bool-null s = _jss_len s == 0+null s = veryUnsafePerformIO (_jss_len s) == 0  -- | O(1) Get the length of a JSString as an Int. length :: JSString -> Int-length s = _jss_len s+length = veryUnsafePerformIO . _jss_len  -- | O(n) Map a function over the given JSString. map :: (Char -> Char) -> JSString -> JSString-map = _jss_map+map f s = _jss_map f s  -- | O(n) reverse a JSString. reverse :: JSString -> JSString-reverse = _jss_rev+reverse = veryUnsafePerformIO . _jss_rev  -- | O(n) Join a list of JSStrings, with a specified separator. Equivalent to --   'String.join'.@@ -293,11 +322,11 @@ -- | O(n) Determines whether the given JSString matches the given regular --   expression or not. matches :: JSString -> RegEx -> Bool-matches = _jss_re_match+matches s re = veryUnsafePerformIO $ _jss_re_match s re  -- | O(n) Find all strings corresponding to the given regular expression. match :: RegEx -> JSString -> [JSString]-match re s = fromPtr $ _jss_re_find re s+match re s = veryUnsafePerformIO $ _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.@@ -308,11 +337,11 @@ regex :: JSString -- ^ Regular expression.       -> JSString -- ^ Potential flags.       -> RegEx-regex re flags = _jss_re_compile re flags+regex re flags = veryUnsafePerformIO $ _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+replace s re rep = veryUnsafePerformIO $ _jss_re_replace s re rep

@@ -46,7 +46,7 @@ topLevelInline :: Stm -> Stm topLevelInline ast =   runTravM $ do-    unTrampoline ast+    pure ast     >>= unevalLits     >>= inlineIntoEval     >>= inlineAssigns@@ -56,6 +56,11 @@     >>= optimizeArrays     >>= zapJSStringConversions     >>= inlineJSPrimitives+    >>= removeUselessEvals+    >>= inlineAssigns+    >>= smallStepInline+    >>= inlineAssigns+    >>= unTrampoline  -- | Attempt to turn two case branches into a ternary operator expression. tryTernary :: Var@@ -75,8 +80,8 @@       -- 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 def'-      alt'' <- inlineAssignsLocal alt'+      def'' <- inlineAssigns def'+      alt'' <- inlineAssigns alt'       -- If self occurs in either branch, we can't inline or we risk ruining       -- tail call elimination.       selfInDef <- occurrences (const True) selfOccurs def''@@ -89,12 +94,13 @@ tryTernary _ _ _ _ _ =   Nothing --- | Remove bogus assignments of the form @literal = exp@, which may arise from---   other optimizations.+-- | Remove bogus assignments of the form @literal = exp@ and @_ = _@,+--   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+removeNonsenseAssigns (Assign (LhsExp _ (Lit _)) _ next)          = next+removeNonsenseAssigns (Assign (LhsExp _ a) b next)       | a == b = next+removeNonsenseAssigns (Assign (NewVar _ a) (Var b) next) | a == b = next+removeNonsenseAssigns stm                                         = stm  -- | How many times does an expression satisfying the given predicate occur in --   an AST (including jumps)?@@ -115,63 +121,87 @@ --   things horribly. --   Ignores LhsExp assignments, since we only introduce those when we actually --   care about the assignment side effect.------   Note: a thunk may ONLY be inlined into a lambda if it performs no useful---         work, to avoid computing expensive thunks more than once. inlineAssigns :: JSTrav ast => ast -> TravM ast inlineAssigns ast = do-    inlinable <- gatherInlinable ast+    inlinable <- countVarOccs ast     mapJS (const True) return (inl inlinable) ast   where-    varOccurs lhs (Exp (Var lhs') _) = lhs == lhs'-    varOccurs _ _                    = False+    -- Assume that an assignment that is never used is actually there for a+    -- good reason and thus not inlinable.+    isSafe i v+      | Just Once <- M.lookup v i = True+      | otherwise                 = False -    appearsLHS ex =-      foldJS (\x _ -> not x) (\x s -> return $ x || ex `isLHSOf` s) False+    atLeastOnce i v+      | Just occs <- M.lookup v i = occs > Never+      | otherwise                 = 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+    isJSLit (Exp (JSLit {}) _) = True+    isJSLit _                  = 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+    isVar v (Exp (Var v') _) = v == v'+    isVar _ _                = False +    isWritten v (Exp (AssignEx (Var v') _) _)            = v == v'+    isWritten v (Stm (Assign (LhsExp _ (Var v')) _ _) _) = v == v'+    isWritten _ _                                        = False++    -- It's OK to inline lambda-likes into anything that's not a loop or a+    -- function (thunks are OK because they only get evaluated once).+    goodInlineTgt = not <$> isLoop .|. isFun++    -- Only inline safe-to-reorder vars - if a var is ever assigned to, it is+    -- insanely unsafe to inline it.+    inl safe keep@(Assign (NewVar True v) rhs next) = do+      written <- occurrences (const True) (isWritten v) next+      case rhs of+        _ | written /= Never -> do+          return keep+        -- String lits: inline if used exactly once to avoid blowing up code size+        l@(Lit (LStr _)) | isSafe safe v -> do+          replaceEx (const True) (Var v) l next++        -- Other lits: inline if used at least once+        l@(Lit _) | atLeastOnce safe v -> do+          occs <- occurrences (const True) (isVar v) next+          if occs > Never+            then replaceEx (const True) (Var v) l next+            else return keep++        -- Variables: inline if used at least once+        v'@(Var {}) | atLeastOnce safe v -> do+          occs <- occurrences (const True) (isVar v) next+          if occs > Never+            then replaceEx (const True) (Var v) v' next+            else return keep++        -- Everything else: inline if only used once and doesn't contain+        -- lambda-likes. Lambda-likes may be inlined if they occur exactly+        -- once, and this occurrence is not in a lambda or a loop.+        ex | isSafe safe v -> do+          lambdaoccs <- occurrences (const True) (isLambda .|. isJSLit) ex+          recursive <- occurrences (const True) (isVar v) ex+          case (lambdaoccs, recursive) of+            (Never, Never) -> do+              (reps, next') <- replaceExWithCount (const True) (Var v) ex next+              if reps == 1+                then return next'+                else return keep+            (Once, Never)  -> do+              -- If we only made a single replacement in a good inline target,+              -- then we know that everything is OK. If not, we accidentally+              -- inlined into a bad code block, so we discard the result.+              (reps, next') <- replaceExWithCount goodInlineTgt (Var v) ex next+              if reps == 1+                then return next'+                else return keep+            _              -> do+              pure keep+        _ -> do+          pure keep+    inl _ keep = do+      pure keep+ -- | 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@@ -192,23 +222,6 @@ 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@@ -229,7 +242,31 @@     inlEx x =       return x +-- | Remove calls to E() where we know for sure the argument is already+--   evaluated.+removeUselessEvals :: JSTrav ast => ast -> TravM ast+removeUselessEvals ast = do+    mapJS (const True) return opt ast+  where+    opt (Assign lhs@(NewVar _ l) rhs next) = do+      Assign lhs rhs <$> case rhs of+        Eval r@(Var _) -> removeEval (Var l) next >>= removeEval r+        _ | isHNF rhs  -> removeEval (Var l) next+          | otherwise  -> return next+    opt stm = do+      return stm +    isHNF (Lit {})   = True+    isHNF (JSLit {}) = True+    isHNF (Not {})   = True+    isHNF (BinOp {}) = True+    isHNF (Fun {})   = True+    isHNF (Arr {})   = True+    isHNF (Eval {})  = True+    isHNF _          = False++    removeEval x = replaceEx (const True) (Eval x) x+ -- | Turn toJSStr(unCStr(x)) into x, since rewrite rules absolutely refuse --   to work with unpackCString#. --   Also turn T(unCStr(x)) into unCStr(x) whenever x is a literal, since@@ -312,12 +349,10 @@     Just (ThunkRet ex') -> Just ex'     _                   -> Nothing --- | Gather a map of all inlinable symbols; that is, the ones that are used---   exactly once.-gatherInlinable :: JSTrav ast => ast -> TravM (M.Map Var Occs)-gatherInlinable ast = do-    m <- foldJS (\_ _->True) countOccs (M.empty) ast-    return (M.filter (< Lots) m)+-- | Count the occurrences of all variables in an AST.+countVarOccs :: JSTrav ast => ast -> TravM (M.Map Var Occs)+countVarOccs ast = do+    foldJS (\_ _->True) countOccs (M.empty) ast   where     updVar (Just occs) = Just (occs+Once)     updVar _           = Just Once@@ -343,11 +378,11 @@ --     eliminated. mayTailcall :: JSTrav ast => ast -> TravM Bool mayTailcall ast = do-  foldJS enter countTCs False ast+    foldJS enter countTCs False ast   where     enter True _                = False     enter _ (Exp (Thunk _ _) _) = False---    enter _ (Exp (Fun _ _) _)   = False+    enter _ (Exp (Fun _ _) _)   = False     enter _ _                   = True     countTCs _ (Stm (Tailcall _) _) = return True     countTCs acc _                  = return acc@@ -360,6 +395,8 @@   where     countTCs s (Exp (Var v@(Foreign _)) _) = do       return $ S.insert v s+    countTCs s (Stm (Assign (NewVar _ v) (JSLit {}) _) _) = do+      return $ S.insert v s     countTCs s (Stm (Assign (NewVar _ v) (Fun _ body) _) _) = do       tc <- mayTailcall body       return $ if not tc then S.insert v s else s      @@ -382,6 +419,9 @@ --   we can apply this procedure recursively three times and still be --   guaranteed to use no more stack frames than we would have without this --   optimization.+--+--   Note that we can only do this for fast calls, as we need to be able to+--   know exactly what function is actually called upon saturated application. unTrampoline :: Stm -> TravM Stm unTrampoline = go >=> go >=> go   where@@ -389,15 +429,9 @@       ntcs <- gatherNonTailcalling s       mapJS (const True) (unTr ntcs) (unTC ntcs) s -    unTr ntcs (Call ar (Normal True) f@(Var v) xs)-      | v `S.member` ntcs =-        return $ Call ar (Normal False) f xs     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-        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         tc <- mayTailcall body         return $ if tc then c else Call ar (Fast False) f xs@@ -408,44 +442,15 @@     -- tailcall in turn we should not tailcall it, since that would mean two     -- activation records on the stack - one for the trampoline and one for     -- the function itself.-    unTC ntcs (Tailcall c@(Call _ _ (Var v) _))+    unTC ntcs (Tailcall c@(Call _ (Fast _) (Var v) _))       | v `S.member` ntcs =         return $ Return c-    unTC _ tc@(Tailcall c@(Call _ _ (Fun _ body) _)) = do+    unTC _ tc@(Tailcall c@(Call _ (Fast _) (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.-inlineAssignsLocal :: JSTrav ast => ast -> TravM ast-inlineAssignsLocal ast = do-    mapJS isSafeForInlining return inl ast-  where-    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-        _ ->-          return keep-    inl stm = return stm- -- | Turn sequences like `v0 = foo; v1 = v0; v2 = v1; return v2;` into a --   straightforward `return foo;`. --   Ignores LhsExp assignments, since we only introduce those when we actually@@ -463,7 +468,7 @@     go outside (Case c d as next) = do       next' <- go outside next       case returnLike next' of-        outside'@(Just _) ->+        outside'@(Just (Var _, _)) ->           Case c <$> go outside' d <*> mapM (goAlt outside') as <*> pure Stop         _ ->           Case c <$> go Nothing d <*> mapM (goAlt Nothing) as <*> pure next'@@ -539,12 +544,13 @@             let args' = map newName args                 ret = Return (Lit $ LNull)             b <- mapJS (not <$> isLambda) pure (replaceByAssign ret args') body+            tailcalls <- occurrences (const True) isHiddenTailcall body             let nn = newName f                 nv = NewVar False nn                 body' =                   Forever $-                  Assign nv (Call 0 (Fast False) (Fun args b)-                                                 (map Var args')) $+                  Assign nv (Call 0 (Fast (tailcalls > Never)) (Fun args b)+                                                               (map Var args')) $                   Case (Var nn) (Return (Var nn)) [(Lit $ LNull, Stop)] $                   Stop             return $ Fun args' body'@@ -557,6 +563,9 @@   where     isTailRec (Stm (Return (Call _ _ (Var f') _)) _) = f == f'     isTailRec _                                      = False++    isHiddenTailcall (Stm (Return (Call {})) _) = True+    isHiddenTailcall _                          = False          -- Only traverse until we find a closure     createsClosures = foldJS (\acc _ -> not acc) isClosure False@@ -581,7 +590,7 @@         (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)+        (next, Assign (LhsExp False (Var v)) x final)          newName (Internal (Name n mmod) _ _) =       Internal (Name (BS.cons ' ' n) mmod) "" True@@ -752,7 +761,7 @@  -- | 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.+--   computation to take place or a variable to be dereferenced. safeToUnThunk :: Exp -> Bool safeToUnThunk ex =   case ex of

@@ -126,9 +126,9 @@   pp (Eval x) = do     "E(" .+. pp x .+. ")"   pp (Thunk True x) = do-    "new T(function(){" .+. newl .+. indent (pp x) .+. "})"+    "new T(function(){" .+. newl .+. indent (pp x) .+. ind .+. "})"   pp (Thunk False x) = do-    "new T(function(){" .+. newl .+. indent (pp x) .+. "},1)"+    "new T(function(){" .+. newl .+. indent (pp x) .+. ind .+. "},1)"  instance Pretty (Var, Exp) where   pp (v, ex) = pp v .+. sp .+. "=" .+. sp .+. pp ex@@ -140,7 +140,7 @@ -- | Print a series of NewVars at once, to avoid unnecessary "var" keywords. ppAssigns :: Stm -> PP () ppAssigns stm = do-    line $ "var " .+. ppList sep assigns .+. ";"+    line $ "var " .+. ppList ("," .+. newl .+. ind) assigns .+. ";"     pp next   where     (assigns, next) = gather [] stm

@@ -254,10 +254,18 @@ -- | Thunks and explicit lambdas count as lambda abstractions. {-# INLINE isLambda #-} isLambda :: ASTNode -> Bool-isLambda (Exp (Fun _ _) _)   = True-isLambda (Exp (Thunk _ _) _) = True-isLambda _                   = False+isLambda = isThunk .|. isFun +{-# INLINE isThunk #-}+isThunk :: ASTNode -> Bool+isThunk (Exp (Thunk _ _) _) = True+isThunk _                   = False++{-# INLINE isFun #-}+isFun :: ASTNode -> Bool+isFun (Exp (Fun _ _) _)   = True+isFun _                   = False+ {-# INLINE isLoop #-} isLoop :: ASTNode -> Bool isLoop (Stm (Forever _) _) = True@@ -276,7 +284,7 @@  {-# INLINE isSafeForInlining #-} isSafeForInlining :: ASTNode -> Bool-isSafeForInlining = not <$> isLambda .|. isLoop .|. isShared+isSafeForInlining = not <$> isFun .|. isLoop .|. isShared  -- | Counts occurrences. Use ints or something for a more exact count. data Occs = Never | Once | Lots deriving (Eq, Show)

@@ -15,9 +15,9 @@  stdJSLibs :: [FilePath] stdJSLibs = map (jsDir </>)  [-    "rts.js", "floatdecode.js", "stdlib.js", "jsstring.js", "endian.js",+    "rts.js", "floatdecode.js", "stdlib.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",+    "pointers.js", "cheap-unicode.js", "Handle.js", "Weak.js",     "Foreign.js"   ] 

@@ -304,12 +304,30 @@     UnmaskAsyncExceptionsOp -> Right $ callSaturated (head xs) []     MaskStatus              -> Right $ litN 0 -    -- Misc. ops+    -- Bitwise ops     PopCntOp       -> Right $ callForeign "popCnt" [head xs]     PopCnt8Op      -> Right $ callForeign "popCnt" [head xs]     PopCnt16Op     -> Right $ callForeign "popCnt" [head xs]     PopCnt32Op     -> Right $ callForeign "popCnt" [head xs]     PopCnt64Op     -> Right $ callForeign "popCnt64" [head xs]++#if __GLASGOW_HASKELL__ >= 710+    ClzOp          -> Right $ callForeign "__clz" [litN 32, head xs]+    Clz8Op         -> Right $ callForeign "__clz" [litN 8,  head xs]+    Clz16Op        -> Right $ callForeign "__clz" [litN 16, head xs]+    Clz32Op        -> Right $ callForeign "__clz" [litN 32, head xs]++    CtzOp          -> Right $ callForeign "__ctz" [litN 32, head xs]+    Ctz8Op         -> Right $ callForeign "__ctz" [litN 8,  head xs]+    Ctz16Op        -> Right $ callForeign "__ctz" [litN 16, head xs]+    Ctz32Op        -> Right $ callForeign "__ctz" [litN 32, head xs]    +#endif++    -- Concurrency - only relevant in a threaded environment+    NoDuplicateOp  -> Right $ defState+    MyThreadIdOp   -> Right $ litN 0 -- thread ID is always 0++    -- Misc. ops     DelayOp        -> Right $ defState     SeqOp          -> Right $ eval $ head xs     AtomicallyOp   -> Right $ callSaturated (xs !! 0) []@@ -320,8 +338,6 @@     TouchOp        -> Right $ defState     RaiseOp        -> callF "die"     RaiseIOOp      -> callF "die"-    -- noDuplicate is only relevant in a threaded environment.-    NoDuplicateOp  -> Right $ defState     CatchOp        -> callF "jsCatch"     x              -> Left $ "Unsupported PrimOp: " ++ showOutputable cfg x   where

@@ -12,7 +12,7 @@  -- | Current Haste version. hasteVersion :: Version-hasteVersion = Version [0,5,1,3] []+hasteVersion = Version [0,5,2] []  -- | Current Haste version as an Int. The format of this version number is --   MAJOR*10 000 + MINOR*100 + MICRO.

@@ -147,10 +147,10 @@            "Build standard libs for tracing of primitive " ++            "operations. Only use if you're debugging the code " ++            "generator."+#endif     , Option "v" ["verbose"]            (NoArg $ \cfg -> cfg {verbose = True}) $            "Print absolutely everything."-#endif   ]  hdr :: String@@ -178,6 +178,7 @@     (cfgs, nonopts, errs) -> do       mapM_ putStr errs       mapM_ (\x -> putStrLn $ "unrecognized option `" ++ x ++ "'") nonopts+      exitFailure  bootHaste :: Cfg -> FilePath -> Shell () bootHaste cfg tmpdir =