packages feed

haste-compiler 0.2.11 → 0.2.99

raw patch · 53 files changed

+4508/−32 lines, 53 filesdep +data-binary-ieee754dep +integer-gmpdep +monads-tfdep ~shellmate

Dependencies added: data-binary-ieee754, integer-gmp, monads-tf, utf8-string, websockets

Dependency ranges changed: shellmate

Files

haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name:           haste-compiler-Version:        0.2.11+Version:        0.2.99 License:        BSD3 License-File:   LICENSE Synopsis:       Haskell To ECMAScript compiler@@ -78,7 +78,7 @@         network,         HTTP,         executable-path,-        shellmate >= 0.1.1+        shellmate >= 0.1.3     Default-Language: Haskell98  Executable hastec@@ -199,3 +199,72 @@         executable-path,         shellmate     default-language: Haskell98++Library+    Hs-Source-Dirs: libraries/haste-lib/src, libraries/fursuit/src, src+    GHC-Options: -Wall -O2+    Exposed-Modules:+        FRP.Fursuit+        FRP.Fursuit.Async+        Haste+        Haste.App+        Haste.App.Concurrent+        Haste.Binary+        Haste.Compiler+        Haste.JSON+        Haste.Ajax+        Haste.Reactive+        Haste.DOM+        Haste.Prim+        Haste.Concurrent+        Haste.Graphics.Canvas+        Haste.Foreign+        Haste.Serialize+        Haste.Parsing+        Haste.WebSockets+        Haste.LocalStorage+    Other-Modules:+        FRP.Fursuit.Signal+        FRP.Fursuit.Sink+        FRP.Fursuit.Pipe+        FRP.Fursuit.Locking+        Haste.JSType+        Haste.Callback+        Haste.Compiler.Flags+        Haste.Environment+        Paths_haste_compiler+        Haste.Hash+        Haste.Random+        Haste.Reactive.DOM+        Haste.Reactive.Ajax+        Haste.Concurrent.Monad+        Haste.Concurrent.Ajax+        Haste.App.Client+        Haste.App.Events+        Haste.App.Monad+        Haste.App.Protocol+        Haste.Binary.Get+        Haste.Binary.Put+        Haste.Binary.Types+    Build-Depends:+        integer-gmp,+        transformers,+        monads-tf,+        ghc-prim,+        containers,+        base < 5,+        array,+        random,+        binary,+        data-binary-ieee754,+        bytestring >= 0.9.2.1,+        websockets >= 0.8,+        utf8-string,+        -- For Haste.Compiler+        shellmate >= 0.1.3,+        data-default,+        directory,+        executable-path,+        filepath,+        process+    Default-Language: Haskell98
lib/Int64.js view
@@ -12,7 +12,7 @@ // See the License for the specific language governing permissions and // limitations under the License. -Long = function(low, high) {+var Long = function(low, high) {   this.low_ = low | 0;   this.high_ = high | 0; };
lib/Integer.js view
@@ -45,12 +45,12 @@   } }; -I_fromBits = function(bits) {+var I_fromBits = function(bits) {   var high = bits[bits.length - 1];   return new Integer(bits, high & (1 << 31) ? -1 : 0); }; -I_fromString = function(str, opt_radix) {+var I_fromString = function(str, opt_radix) {   if (str.length == 0) {     throw Error('number format error: empty string');   }
lib/md5.js view
@@ -100,7 +100,6 @@ }  function md51(s) {-txt = ''; var n = s.length, state = [1732584193, -271733879, -1732584194, 271733878], i; for (i=64; i<=s.length; i+=64) {
lib/rts.js view
@@ -31,7 +31,7 @@     // Closure does some funny stuff with functions that occasionally     // results in non-functions getting applied, so we have to deal with     // it.-    if(!f || f.apply === undefined) {+    if(!(f instanceof Function)) {         return f;     } @@ -39,10 +39,17 @@         f.arity = f.length;     }     if(args.length === f.arity) {-        return f.arity === 1 ? f(args[0]) : f.apply(null, args);+        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) {-        return f.arity === 1 ? A(f(args.shift()), args)-                             : A(f.apply(null, args.splice(0, f.arity)), args);+        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)));@@ -68,6 +75,16 @@     } } +// Export Haste, A and E. Haste because we need to preserve exports, A and E+// because they're handy for Haste.Foreign.+if(!window) {+    var window = {};+}+window['Haste'] = Haste;+window['A'] = A;+window['E'] = E;++ /* Throw an error.    We need to be able to use throw as an exception so we wrap it in a function. */@@ -150,7 +167,7 @@ }  function err(str) {-    die(toJSStr(str)[1]);+    die(toJSStr(str)); }  /* unpackCString#@@ -223,7 +240,8 @@     return le; } -var isFloatNaN = isDoubleNaN = isNaN;+var isDoubleNaN = isNaN;+var isFloatNaN = isNaN;  function isDoubleInfinite(d) {     return (d === Infinity);
lib/stdlib.js view
@@ -125,7 +125,11 @@ }  function jsGetAttr(elem, prop) {-    return elem.getAttribute(prop).toString();+    if(elem.hasAttribute(prop)) {+        return elem.getAttribute(prop).toString();+    } else {+        return "";+    } }  function jsSetAttr(elem, prop, val) {@@ -229,9 +233,9 @@     return arr.join(sep); } -// Escape all double quotes in a string-function jsUnquote(str) {-    return str.replace(/"/g, '\\"');+// JSON stringify a string+function jsStringify(str) {+    return JSON.stringify(str); }  // Parse a JSON message into a Haste.JSON.JSON value.@@ -290,6 +294,14 @@     return [1, toHS(arr[elem]), new T(function() {return arr2lst(arr,elem+1);})] } +function lst2arr(xs) {+    var arr = [];+    for(; xs[0]; xs = E(xs[2])) {+        arr.push(E(xs[1]));+    }+    return arr;+}+ function ajaxReq(method, url, async, postdata, cb) {     var xhr = new XMLHttpRequest();     xhr.open(method, url, async);@@ -304,4 +316,34 @@         }     }     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; }
+ libraries/fursuit/src/FRP/Fursuit.hs view
@@ -0,0 +1,106 @@+-- | Oversimplified FRP library, using no concurrency primitives.+--   As it's primarily intended to be used with haste-compiler, compiled to+--   Javascript, this library is NOT thread-safe, though it could be made so+--   by simply slamming a global lock around the write and newSinkID+--   operations.+module FRP.Fursuit (module Sink, module Pipe, Signal, sink, new, union, accumS,+                    filterS, whenS, zipS, untilS, fromS, stateful, unions,+                    filterMapS) where+import FRP.Fursuit.Signal+import FRP.Fursuit.Pipe as Pipe+import FRP.Fursuit.Sink as Sink+import System.IO.Unsafe+import Control.Applicative+import Data.List (foldl1')+import Data.Maybe (fromJust, isJust)++-- | Execute the specified IO action to obtain a new signal when registering+--   signals. This is handy when you're creating a signal from an external+--   event for use with a single sink:+-- @+--   clicked <- buttonSig "my_button"+--   sink (_ -> putStrLn "Button clicked!") clicked+--   -- ...can be rewritten as:+--   sink (_ -> putStrLn "Button clicked!") (new $ buttonSig "my_button")+-- @+{-# NOINLINE new #-}+new :: IO (Signal a) -> Signal a+new = New . unsafePerformIO++-- | Create a signal that has the value of whichever parent signal fired last.+--   The union is left biased.+union :: Signal a -> Signal a -> Signal a+union = Union++-- | The union of n > 1 signals.+unions :: [Signal a] -> Signal a+unions = foldl1' union++-- | Behaves pretty much like scanl on signals. Initialize the accumulator with+--   a default value; every time the function signal triggers, apply the+--   function to the accumulator and pass on the result.+accumS :: a -> Signal (a -> a) -> Signal a+accumS = Accum++-- | Create a signal that keeps local state but returns another value.+stateful :: (st, a) -> Signal (st -> (st, a)) -> Signal a+stateful initial f =+  snd <$> accumS initial (acc <$> f)+  where+    acc fun (st, _) = fun st++-- | Filter out events. filterS pred sig only lets the signal sig through if+--   it fulfills the predicate pred. For example:+-- @+--   (pa, a) <- pipe (0 :: Int)+--   (pb, b) <- pipe (0 :: Int)+--   let plus = (+) <$> filterS (< 10) a <*> b+--   sink (putStrLn . show) plus+--   write pa 20+--   write pb 20+--   write pa 5+-- @+--   The above code will print 20 and 25; writing 20 to pa gets filtered out,+--   as 20 does not fulfull (< 10) so no signal is fired. b isn't so filtered+--   however, so the 20 goes through just fine, and is added to the last good+--   value of a (which is 0 - its initial value). The final 5 does fulfill+--   (< 10), so the signal goes through and we get 25.+filterS :: (a -> Bool) -> Signal a -> Signal a+filterS = Filter++-- | Combined fmap and filter.+filterMapS :: (a -> Maybe b) -> Signal a -> Signal b+filterMapS f sig =+  fromJust <$> filterS isJust (f <$> sig)++{-# RULES+"filterS/filterS" forall p1 p2 sig.+  filterS p1 (filterS p2 sig) = filterS (\x -> p1 x && p2 x) sig+  #-}++-- | Only allow a signal to pass through when the time varying value is true.+whenS :: Signal Bool -> Signal a -> Signal a+whenS p s = snd <$> (filterS fst $ zipS p s)++-- | Signal equivalent of the list function by the same name.+zipS :: Signal a -> Signal b -> Signal (a, b)+zipS a b = (,) <$> a <*> b++-- | Pass through a signal as long as it does not fulfill a predicate. From the+--   point when it does fulfill that predicate, the signal never propagates+--   again unless the reset signal fired.+untilS :: (a -> Bool) -> Signal a -> Signal b -> Signal a+untilS p sig reset =+  snd <$> filterS fst (zipS propagate sig)+  where+    propagate = accumS True update+    update    = (const False <$ filterS p sig) `union` (const True <$ reset)++-- | Don't pass the signal through until it fulfills a predicate. After the+--   predicate has been fulfilled at least once, always propagate the signal.+fromS :: (a -> Bool) -> Signal a -> Signal b -> Signal a+fromS p sig reset =+  snd <$> filterS fst (zipS propagate sig)+  where+    propagate = accumS False update+    update    = (const True <$ filterS p sig) `union` (const False <$ reset)
+ libraries/fursuit/src/FRP/Fursuit/Async.hs view
@@ -0,0 +1,33 @@+module FRP.Fursuit.Async where+import Control.Applicative+import FRP.Fursuit.Signal+import FRP.Fursuit.Sink+import FRP.Fursuit.Pipe++-- | Create an asynchronous signal. When the signal is triggered, it should+--   arrange for a value to written into its obtained pipe at some point in+--   the future; when that happens, the signal continues on its path.+--+--   The signal setup action is guaranteed to be called exactly once per+--   received signal; thus the following code will print 1 two times rather+--   than 1 followed by 2:+-- @+--   ref <- newIORef ()+--   (p, s) <- pipe ()+--   sig <- async $ (\p -> modifyIORef ref (+1) >> write p ref) <$ s+--   sink (\r -> readIORef r >>= print) sig+--   sink (\r -> readIORef r >>= print) sig+--   write p ()+-- @+--   Async is primarily intended as a building block for other more high level+--   signals, and should be used with extreme care as it permits arbitrary side+--   effects to happen in the course of propagating a signal.+--+--   It's also worth noting that triggering the signal returned by async does+--   not trigger the setup signal, but will instead use the last value held by+--   the output signal, if any.+async :: Signal (Pipe a -> IO ()) -> IO (Signal a)+async setup = do+  (p,s) <- emptyPipe+  perform $ setup <*> pure p+  return s
+ libraries/fursuit/src/FRP/Fursuit/Locking.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+-- | Locking for Fursuit - to enable running it safely on multithreaded+--   platforms.+module FRP.Fursuit.Locking (withFursuitLock) where++#ifdef __HASTE__++-- | The Haste version is just a no-op; no threads in the browser!+withFursuitLock :: IO a -> IO a+withFursuitLock = id++#else++import Control.Concurrent.MVar+import System.IO.Unsafe++{-# NOINLINE fursuitLock #-}+-- | While this may seem insanely unsafe due to blackholing, it's actually+--   perfectly OK as of GHC 7.4.2, when CAFs were made atomic.+--   (http://hackage.haskell.org/trac/ghc/ticket/5558)+fursuitLock :: MVar ()+fursuitLock = unsafePerformIO $! newMVar ()++-- | The GHC version is really stupid: smack a big lock around the entire+--   write operation. It works, but it's neither elegant nor efficient.+withFursuitLock :: IO a -> IO a+withFursuitLock action = do+  _ <- takeMVar fursuitLock+  res <- action+  putMVar fursuitLock ()+  return res++#endif
+ libraries/fursuit/src/FRP/Fursuit/Pipe.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE BangPatterns, CPP #-}+-- | Pipes are the only way to cause a 'Signal' to fire from the outside.+module FRP.Fursuit.Pipe (Pipe, pipe, emptyPipe, write) where+import Data.IORef+import FRP.Fursuit.Signal+import qualified Data.IntMap as M+import FRP.Fursuit.Locking++-- | Create a pipe. Writing to a pipe is the only way to manually trigger a+--   signal.+emptyPipe :: IO (Pipe a, Signal a)+emptyPipe = do+  ref <- newIORef Nothing+  orig <- newIORef False+  sinks <- newIORef M.empty+  return (P ref sinks orig, Pipe ref sinks orig)++-- | Create a pipe with an initial value.+pipe :: a -> IO (Pipe a, Signal a)+pipe !initially = do+  ps@(P ref _ _, _) <- emptyPipe+  writeIORef ref (Just initially)+  return ps++-- | Write a value into a pipe. This will cause the pipe's associated signal+--   to fire.+write :: Pipe a -> a -> IO ()+write (P value listeners origin) !x = withFursuitLock $ do+  writeIORef origin True+  writeIORef value (Just x)+  readIORef listeners >>= M.foldl' (>>) (return ())+  writeIORef origin False
+ libraries/fursuit/src/FRP/Fursuit/Signal.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE GADTs, BangPatterns, TupleSections #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+module FRP.Fursuit.Signal (Signal (..), Pipe (..), sink) where+import Data.IORef+import System.IO.Unsafe+import Control.Applicative+import qualified Data.IntMap as M+import Data.Maybe++type SinkID = Int+type Origin = Bool+type Sig a = IO (Maybe (a, Origin))+type SinkList = M.IntMap (IO ())++data Pipe a = P {+    piperef :: IORef (Maybe a),+    cbref   :: IORef (M.IntMap (IO ())),+    origref :: IORef Origin+  }++-- New is implemented as a thin wrapper around unsafePerformIO, to make sure+-- it's only evaluated once and never outside of sink.+data Signal a where+  App    :: Signal (a -> b) -> Signal a -> Signal b+  Pure   :: a -> Signal a+  Pipe   :: IORef (Maybe a) -> IORef SinkList -> IORef Origin -> Signal a+  Filter :: (a -> Bool) -> Signal a -> Signal a+  Accum  :: a -> Signal (a -> a) -> Signal a+  New    :: Signal a -> Signal a+  Union  :: Signal a -> Signal a -> Signal a++{-# NOINLINE sinkIDs #-}+sinkIDs :: IORef SinkID+sinkIDs = unsafePerformIO $ newIORef 0++-- | Generate a new sink ID, and update the global list of such IDs.+newSinkID :: IO SinkID+newSinkID = do+  sid <- readIORef sinkIDs+  writeIORef sinkIDs $! sid+1+  return sid++-- | Attach a signal to an actuator.+sink :: (a -> IO ()) -> Signal a -> IO ()+sink act sig = do+  sig' <- compile sig >>= return . mkSnk act+  sid <- newSinkID+  mapM_ (\sinks -> modifyIORef sinks (M.insert sid sig')) (sources sig)+  where+    mkSnk action signal = do+      result <- signal+      case result of+        Just (val, actuallyHappened) | actuallyHappened -> action val+        _                                               -> return ()++    -- Find all sources for this signal+    sources :: Signal a -> [IORef SinkList]+    sources (App f x)      = sources f ++ sources x+    sources (Pure _)       = []+    sources (Pipe _ src _) = [src]+    sources (Filter _ s)   = sources s+    sources (Accum _ s)    = sources s+    sources (New s)        = sources s+    sources (Union a b)    = sources a ++ sources b+    +    -- Compile the signal into an IO action we can trigger whenever one of its+    -- sources gets a signal.+    compile :: Signal a -> IO (Sig a)+    compile (App sf sx) = do+      f <- compile sf+      x <- compile sx+      return (f `appS` x)+    compile (Pure x) = do+      return (return $ Just (x, False))+    compile (Pipe value _ origin) = do+      return $ do+        mval <- readIORef value+        orig <- readIORef origin+        return $ mval >>= \val -> return (val, orig)+    compile (Filter predicate s) = do+      s' <- compile s+      ms <- s'+      lastGood <- case ms of+        Just (initial, _) | predicate initial -> newIORef (Just initial)+        _                                     -> newIORef Nothing+      s'' <- compile s+      return (fltS predicate lastGood s'')+    compile (Accum initially s) = do+      s' <- compile s+      ref <- newIORef initially+      return (accS ref s')+    compile (New signal) = do+      compile signal+    compile (Union a b) = do+      a' <- compile a+      b' <- compile b+      -- Prefer to initialize with the value of the left signal.+      maval <- a'+      initial <- case maval of+        Just (x, _) -> return (Just x)+        _           -> do+          mbval <- b'+          case mbval of+            Just (x, _) -> return (Just x)+            _           -> return Nothing+      prev <- newIORef initial+      return $ uniS a' b' prev++-- | Union of two events. Both events are always evaluated.+uniS :: Sig a -> Sig a -> IORef (Maybe a) -> Sig a+uniS sa sb prevref = do+  ma <- sa+  mb <- sb+  prev <- readIORef prevref+  case listToMaybe $ filter snd $ catMaybes [ma, mb] of+    Nothing -> do+      return $ fmap (, False) prev+    val -> do+      writeIORef prevref (fmap fst val)+      return val++-- | Basically ap or <*>, but takes the origin indicator into account.+appS :: Sig (a -> b) -> Sig a -> Sig b+appS sf sx = do+  mf <- sf+  mx <- sx+  return $ do+    (f, origf) <- mf+    (x, origx) <- mx+    return (f x, origf || origx)++-- | filterS, with a memo reference for the last value that passed through.+fltS :: (a -> Bool) -> IORef (Maybe a) -> Sig a -> Sig a+fltS predicate lastGood signal = do+  msig <- signal+  case msig of+    Just (val, orig) -> do+      if predicate val && orig+        then do+          writeIORef lastGood (Just val)+          return $ Just (val, True)+        else do+          mlast <- readIORef lastGood+          case mlast of+            Just lastVal -> return $ Just (lastVal, False)+            _            -> return Nothing+    _ -> do+      return Nothing++-- | accumS+accS :: IORef a -> Sig (a -> a) -> Sig a+accS lastRef sf = do+  mf <- sf+  case mf of+    Just (f, orig) -> do+      if orig+        then do+          val <- readIORef lastRef+          let !x = f val+          writeIORef lastRef x+          return $ Just (x, True)+        else do+          lastVal <- readIORef lastRef+          return $ Just (lastVal, False)+    Nothing -> do+          -- Even if upstream can't compute its value, Accum can.+          lastVal <- readIORef lastRef+          return $ Just (lastVal, False)++instance Functor Signal where+  fmap f x = pure f <*> x++instance Applicative Signal where+  pure  = Pure+  (<*>) = App
+ libraries/fursuit/src/FRP/Fursuit/Sink.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-- | Various kinds of sinks.+module FRP.Fursuit.Sink (Sink (..), perform) where+import Data.IORef+import FRP.Fursuit.Signal+import FRP.Fursuit.Pipe++-- | Perform the IO action returned by a signal whenever triggered.+perform :: Signal (IO ()) -> IO ()+perform = sink id++-- | Bind a signal to a value of some type. Examples of instances would be+--   IORef, where ref << sig would store the value of sig in ref whenever+--   triggered, or Pipe, where p << sig would write the value of sig to p.+class Sink s a where+  (<<) :: s -> Signal a -> IO ()+infixl 0 <<++instance Sink (Pipe a) a where+  p << s = sink (write p) s++instance Sink (IORef a) a where+  ref << s = sink (writeIORef ref) s++instance Sink (a -> IO ()) a where+  act << s = sink act s
+ libraries/haste-lib/src/Haste.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, CPP #-}+module Haste (+    JSString, JSAny, URL, CB.GenericCallback,+    alert, prompt, eval, writeLog, catJSStr, fromJSStr,+    module Haste.JSType, module Haste.DOM, module Haste.Callback,+    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.Random+import Haste.JSType+import Haste.DOM+import Haste.Hash+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+#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++-- | Javascript alert() function.+alert :: MonadIO m => String -> m ()+alert = liftIO . jsAlert . toJSStr++-- | Javascript prompt() function.+prompt :: MonadIO m => String -> m String+prompt q = liftIO $ do+  a <- jsPrompt (toJSStr q)+  return (fromJSStr a)++-- | Javascript eval() function.+eval :: MonadIO m => String -> m String+eval js = liftIO $ jsEval (toJSStr js) >>= return . fromJSStr++-- | Use console.log to write a message.+writeLog :: MonadIO m => String -> m ()+writeLog = liftIO . jsLog . toJSStr
+ libraries/haste-lib/src/Haste/Ajax.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP #-}+-- | Low level XMLHttpRequest support. IE6 and older are not supported.+module Haste.Ajax (Method (..), URL, Key, Val, textRequest, textRequest_,+                   jsonRequest, jsonRequest_) where+import Haste.Prim+import Haste.Callback+import Haste.JSON+import Control.Monad.IO.Class++#ifdef __HASTE__+foreign import ccall ajaxReq :: JSString    -- method+                             -> JSString    -- url+                             -> Bool        -- async?+                             -> JSString    -- POST data+                             -> JSFun (Maybe JSString -> IO ())+                             -> IO ()+#else+ajaxReq :: JSString -> JSString -> Bool -> JSString -> JSFun (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]++-- | Make an AJAX request to a URL, interpreting the response as JSON.+jsonRequest :: MonadIO m+            => Method+            -> URL+            -> [(Key, Val)]+            -> (Maybe JSON -> IO ())+            -> 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 "" cb'+  return ()+  where+    liftEither (Right x) = Just x+    liftEither _         = Nothing+    cb' = mkCallback $ \mjson -> cb (mjson >>= liftEither . decodeJSON)+    url' = if null kv then url else catJSStr "?" [url, toQueryString kv]++toQueryString :: [(JSString, JSString)] -> JSString+toQueryString = catJSStr "&" . map (\(k,v) -> catJSStr "=" [k,v])
+ libraries/haste-lib/src/Haste/App.hs view
@@ -0,0 +1,32 @@+-- | Type-safe client-server communication framework for Haste.+--   This module re-exports most of the Haste module for convenience since some+--   functions are exported by both Haste and Haste.App with different+--   definitions. For simplicity, import one or the other, not both.+module Haste.App (+    MonadIO, Exportable, App, Server, Useless, Export, Done,+    Sessions, SessionID,+    liftServerIO, forkServerIO, export, runApp,+    (<.>), mkUseful, getSessionID, getActiveSessions, onSessionEnd,+    AppCfg, cfgURL, cfgPort, mkConfig,+    Client,+    runClient, onServer, liftIO,+    JSString, JSAny, URL, alert, prompt, eval, writeLog, catJSStr, fromJSStr,+    module Haste.App.Events,+    module Haste.DOM,+    module Haste.Random,+    module Haste.JSType,+    module Haste.Hash,+    module Haste.Binary,+    module Data.Default+  ) where+import Haste.App.Client+import Haste.App.Monad+import Haste.App.Events+import Haste.Binary (Binary (..))+import Haste.DOM+import Haste.Random+import Haste.JSType+import Haste.Hash+import Haste+import Control.Monad.IO.Class+import Data.Default
+ libraries/haste-lib/src/Haste/App/Client.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, MultiParamTypeClasses,+             FlexibleInstances #-}+module Haste.App.Client (+    Client, ClientState,+    runClient, onServer, liftCIO, get, runClientCIO+  ) where+import Haste+import Haste.WebSockets+import Haste.Binary hiding (get)+import Haste.App.Monad+import Haste.App.Protocol+import Control.Applicative+import Control.Monad (ap, join)+import Control.Monad.IO.Class+import Control.Exception (throw)+import Data.IORef++data ClientState = ClientState {+    csWebSocket  :: WebSocket,+    csNonce      :: IORef Int,+    csResultVars :: IORef [(Int, MVar Blob)]+  }++initialState :: IORef Int -> IORef [(Int,MVar Blob)] -> WebSocket -> ClientState+initialState n mv ws =+  ClientState {+    csWebSocket  = ws,+    csNonce      = n,+    csResultVars = mv+  }++-- | A client-side computation. See it as XHaste's version of the IO monad.+newtype Client a = Client {+    unC :: ClientState -> CIO a+  }++instance Monad Client where+  (Client m) >>= f = Client $ \cs -> do+    x <- m cs+    unC (f x) cs+  return x = Client $ \_ -> return x++instance Functor Client where+  fmap f (Client m) = Client $ \cs -> fmap f (m cs)++instance Applicative Client where+  (<*>) = ap+  pure  = return++instance MonadIO Client where+  liftIO m = Client $ \_ -> do+    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+++-- | Lift a CIO action into the Client monad.+liftCIO :: CIO a -> Client a+liftCIO m = Client $ \_ -> m >>= \x -> return x++-- | Get part of the client state.+get :: (ClientState -> a) -> Client a+get f = Client $ \cs -> return (f cs)++-- | Create a new nonce with associated result var.+newResult :: Client (Int, MVar Blob)+newResult = Client $ \cs -> do+  mv <- newEmptyMVar+  nonce <- liftIO $ atomicModifyIORef (csNonce cs) $ \n -> (n+1, n)+  liftIO $ atomicModifyIORef (csResultVars cs) $ \vs -> ((nonce, mv):vs, ())+  return (nonce, mv)++-- | Run a Client computation in the web browser. The URL argument specifies+--   the WebSockets URL the client should use to find the server.+runClient_ :: URL -> Client () -> IO ()+runClient_ url (Client m) = concurrent $ do+    mv <- liftIO $ newIORef []+    n <- liftIO $ newIORef 0+    let errorhandler = error "WebSockets connection died for some reason!"+        computation ws = m (initialState n mv ws)+    withBinaryWebSocket url (handler mv) errorhandler computation+  where+    -- When a message comes in, attempt to extract from it two members "nonce"+    -- and "result". Find the result MVar corresponding to the nonce and write+    -- the result to it, then discard the MVar.+    -- TODO: if the nonce is not found, the result vars list if left as it was.+    --       Maybe we should crash here instead, since this is clearly an+    --       unrecoverable error?+    handler rvars _ msg = do+      msg' <- getBlobData msg+      join . liftIO $ atomicModifyIORef rvars $ \vs ->+        let res = do+              case decode msg' :: Either String ServerException of+                Right e -> throw e+                _       -> return ()+              ServerReply nonce result <- decode msg'+              (var, vs') <- case span (\(n, _) -> n /= nonce) vs of+                              (xs, ((_, y):ys)) -> Right (y, xs ++ ys)+                              _                 -> Left "Bad nonce!"+              return (var, result, vs')+        in case res of+             Right (resvar, result, vs') -> (vs', putMVar resvar result)+             _                           -> (vs, return ())++-- | Launch a client from a Server computation. runClient never returns before+--   the program terminates.+runClient :: Client () -> App Done+runClient m = do+  url <- cfgURL `fmap` getAppConfig+  return . Done $ runClient_ url m++-- | Run a client computation from the CIO monad, using a pre-specified state.+runClientCIO :: ClientState -> Client a -> CIO a+runClientCIO cs (Client m) = m cs++-- | Perform a server-side computation, blocking the client thread until said+--   computation returns. All free variables in the server-side computation+--   which originate in the Client monad must be serializable.+onServer :: Binary a => Export (Server a) -> Client a+onServer (Export cid args) = __call cid (reverse args)++-- | Make a server-side call.+__call :: Binary a => CallID -> [Blob] -> Client a+__call cid args = do+  ws <- get csWebSocket+  (nonce, mv) <- newResult+  liftCIO . wsSendBlob ws . encode $ ServerCall {+      scNonce = nonce,+      scMethod = cid,+      scArgs = args+    }+  resblob <- liftCIO $ takeMVar mv+  res <- getBlobData resblob+  case decode res of+    Right x -> return x+    Left _  -> fail $ "Unable to decode return value!"
+ libraries/haste-lib/src/Haste/App/Concurrent.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE EmptyDataDecls #-}+-- | 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.+--+--   This will likely be the state of Haste concurrency until Javascript gains+--   decent native concurrency support.+module Haste.App.Concurrent (+    C.MVar, MBox, Send, Recv, Inbox, Outbox, C.MonadConc (..),+    fork, forkMany, newMVar, newEmptyMVar, takeMVar, putMVar, peekMVar,+    spawn, receive, statefully, (!), (<!),+    forever+  ) where+import qualified Haste.Concurrent.Monad as C+import Haste.App.Client+import Control.Monad++instance C.MonadConc Client where+  liftConc = liftCIO++-- | Spawn off a concurrent computation.+fork :: Client () -> Client ()+fork m = do+  cs <- get id+  liftCIO . C.forkIO $ runClientCIO cs m++-- | Spawn several concurrent computations.+forkMany :: [Client ()] -> Client ()+forkMany = mapM_ fork++-- | Create a new MVar with the specified contents.+newMVar :: a -> Client (C.MVar a)+newMVar = liftCIO . C.newMVar++-- | Create a new empty MVar.+newEmptyMVar :: Client (C.MVar a)+newEmptyMVar = liftCIO C.newEmptyMVar++-- | Read the value of an MVar. If the MVar is empty, @takeMVar@ blocks until+--   a value arrives. @takeMVar@ empties the MVar.+takeMVar :: C.MVar a -> Client a+takeMVar = liftCIO . C.takeMVar++-- | Put a value into an MVar. If the MVar is full, @putMVar@ will block until+--   the MVar is empty.+putMVar :: C.MVar a -> a -> Client ()+putMVar v x = liftCIO $ C.putMVar v x++-- | Read an MVar without affecting its contents.+--   If the MVar is empty, @peekMVar@ immediately returns @Nothing@.+peekMVar :: C.MVar a -> Client (Maybe a)+peekMVar = liftCIO . C.peekMVar++-- | An MBox is a read/write-only MVar, depending on its first type parameter.+--   Used to communicate with server processes.+newtype MBox t a = MBox (C.MVar a)++data Recv+data Send++type Inbox = MBox Recv+type Outbox = MBox Send++-- | Block until a message arrives in a mailbox, then return it.+receive :: Inbox a -> Client a+receive (MBox mv) = takeMVar mv++-- | Creates a generic process and returns a MBox which may be used to pass+--   messages to it.+--   While it is possible for a process created using spawn to transmit its+--   inbox to someone else, this is a very bad idea; don't do it.+spawn :: (Inbox a -> Client ()) -> Client (Outbox a)+spawn f = do+  p <- newEmptyMVar+  fork $ f (MBox p)+  return (MBox p)++-- | Creates a generic stateful process. This process is a function taking a+--   state and an event argument, returning an updated state or Nothing.+--   @statefully@ creates a @MBox@ that is used to pass events to the process.+--   Whenever a value is written to this MBox, that value is passed to the+--   process function together with the function's current state.+--   If the process function returns Nothing, the process terminates.+--   If it returns a new state, the process again blocks on the event MBox,+--   and will use the new state to any future calls to the server function.+statefully :: st -> (st -> evt -> Client (Maybe st)) -> Client (Outbox evt)+statefully initialState handler = do+    spawn $ loop initialState+  where+    loop st p = do+      mresult <- receive p >>= handler st+      case mresult of+        Just st' -> loop st' p+        _        -> return ()++-- | Write a value to a MBox. Named after the Erlang message sending operator,+--   as both are intended for passing messages to processes.+--   This operation does not block until the message is delivered, but returns+--   immediately.+(!) :: Outbox a -> a -> Client ()+MBox m ! x = fork $ putMVar m x++-- | Perform a Client computation, then write its return value to the given+--   pipe. Mnemonic: the operator is a combination of <- and !.+--   Just like @(!)@, this operation is non-blocking.+(<!) :: Outbox a -> Client a -> Client ()+p <! m = do x <- m ; p ! x
+ libraries/haste-lib/src/Haste/App/Events.hs view
@@ -0,0 +1,40 @@+{-# 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)
+ libraries/haste-lib/src/Haste/App/Monad.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+-- | Haste.App startup monad and configuration.+module Haste.App.Monad (+    Exportable,+    App, Server, Sessions, SessionID, Useless (..), Export (..), Done (..),+    AppCfg, def, mkConfig, cfgURL, cfgPort,+    liftServerIO, forkServerIO, export, getAppConfig,+    mkUseful, runApp, (<.>), getSessionID, getActiveSessions, onSessionEnd+  ) where+import Control.Applicative+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+#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 Data.List (foldl')+#endif++data AppCfg = AppCfg {+    cfgURL                :: String,+    cfgPort               :: Int,+    cfgSessionEndHandlers :: [SessionID -> Server ()]+  }++instance Default AppCfg where+  def = mkConfig "ws://localhost:24601" 24601++-- | Create a default configuration from an URL and a port number.+mkConfig :: String -> Int -> AppCfg+mkConfig url port = AppCfg {+    cfgURL = url,+    cfgPort = port,+    cfgSessionEndHandlers = []+  }++type SessionID = Word64+type Sessions = S.Set SessionID+type Method = [Blob] -> SessionID -> IORef Sessions -> IO Blob+type Exports = M.Map CallID Method+data Useless a = Useful a | Useless+newtype Done = Done (IO ())++data Export a = Export CallID [Blob]++-- | Apply an exported function to an argument.+--   TODO: look into making this Applicative.+(<.>) :: Binary a => Export (a -> b) -> a -> Export b+(Export cid args) <.> arg = Export cid (encode arg:args)++-- | Application monad; allows for exporting functions, limited liftIO,+--   forkIO and launching the client.+newtype App a = App {+    unA :: AppCfg+        -> IORef Sessions+        -> CallID+        -> Exports+        -> IO (a, CallID, Exports, AppCfg)+  }++instance Monad App where+  return x = App $ \c _ cid exports -> return (x, cid, exports, c)+  (App m) >>= f = App $ \cfg sessions cid exports -> do+    res <- m cfg sessions cid exports+    case res of+      (x, cid', exports', cfg') -> unA (f x) cfg' sessions cid' exports'++instance Functor App where+  fmap f m = m >>= return . f++instance Applicative App where+  (<*>) = ap+  pure  = return++-- | Lift an IO action into the Server monad, the result of which can only be+--   used server-side.+liftServerIO :: IO a -> App (Useless a)+#ifdef __HASTE__+{-# RULES "throw away liftServerIO"+          forall x. liftServerIO x = return Useless #-}+liftServerIO _ = return Useless+#else+liftServerIO m = App $ \cfg _ cid exports -> do+  x <- m+  return (Useful x, cid, exports, cfg)+#endif++-- | Fork off a Server computation not bound an API call.+--   This may be useful for any tasks that will keep running for as long as+--   the server is running.+--+--   Calling @getSessionID@ inside this computation will return 0, which will+--   never be generated for an actual session. @getActiveSessions@ works as+--   expected.+forkServerIO :: Server () -> App (Useless ThreadId)+#ifdef __HASTE__+{-# RULES "throw away forkServerIO"+          forall x. forkServerIO x = return Useless #-}+forkServerIO _ = return Useless+#else+forkServerIO (Server m) = App $ \cfg sessions cid exports -> do+  tid <- forkIO $ m 0 sessions+  return (Useful tid, cid, exports, cfg)+#endif++-- | An exportable function is of the type+--   (Serialize a, ..., Serialize result) => a -> ... -> IO result+class Exportable a where+  serializify :: a -> [Blob] -> (SessionID -> IORef Sessions -> IO Blob)++instance Binary a => Exportable (Server a) where+#ifdef __HASTE__+  serializify _ _ = undefined+#else+  serializify (Server m) _ = \sid ss -> fmap encode (m sid ss)+#endif++instance (Binary a, Exportable b) => Exportable (a -> b) where+#ifdef __HASTE__+  serializify _ _ = undefined+#else+  serializify f (x:xs) = serializify (f $! fromEither $ decode (toBD x)) xs+    where+      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!"+#endif++-- | Make a function available to the client as an API call.+export :: Exportable a => a -> App (Export a)+#ifdef __HASTE__+{-# RULES "throw away export's argument"+          forall x. export x =+            App $ \c _ cid _ -> return (Export cid [], cid+1, undefined, c) #-}+export _ = App $ \c _ cid _ ->+    return (Export cid [], cid+1, undefined, c)+#else+export s = App $ \c _ cid exports ->+    return (Export cid [], cid+1, M.insert cid (serializify s) exports, c)+#endif++-- | Register a handler to be run whenever a session terminates.+--   Several handlers can be registered at the same time; they will be run in+--   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 $+  ((), cid, exports, cfg {cfgSessionEndHandlers = s:cfgSessionEndHandlers cfg})+#endif++-- | Returns the application configuration.+getAppConfig :: App AppCfg+getAppConfig = App $ \cfg _ cid exports -> return (cfg, cid, exports, cfg)++-- | Run a Haste.App application. runApp never returns before the program+--   terminates.+--+--   Note that @runApp@'s arguments *must not* depend on any external IO,+--   or the client and server computations may diverge.+--   Ideally, calling runApp should be the first and only thing that happens+--   in main.+runApp :: AppCfg -> App Done -> IO ()+runApp cfg (App s) = do+#ifdef __HASTE__+    (Done client, _, _, _) <- s cfg undefined 0 undefined+    client+#else+    sessions <- newIORef S.empty+    (_, _, exports, cfg') <- s cfg sessions 0 M.empty+    serverEventLoop cfg' sessions exports+#endif++#ifndef __HASTE__+-- | Server's communication event loop. Handles dispatching API calls.+--   TODO: we could consider terminating a client who gets bad data, as that is+--         a sure side of outside interference.+serverEventLoop :: AppCfg -> IORef Sessions -> Exports -> IO ()+serverEventLoop cfg sessions exports = do+    WS.runServer "0.0.0.0" (cfgPort cfg) $ \pending -> do+      conn <- acceptRequest pending+      sid <- randomRIO (1, 0xFFFFFFFFFFFFFFFF)+      atomicModifyIORef sessions $ \s -> (S.insert sid s, ())+      clientLoop sid sessions conn+  where+    cleanup :: Connection -> SessionID -> IORef Sessions -> IO ()+    cleanup conn deadsession sref = do+      let f next m = unS (m deadsession) deadsession sref >> next+      foldl' f (return ()) (cfgSessionEndHandlers cfg)+      atomicModifyIORef sref $ \cs -> (S.delete deadsession cs, ())+      let Blob bs = encode $ ServerException "Session ended"+      sendTextData conn bs++    clientLoop :: SessionID -> IORef Sessions -> Connection -> IO ()+    clientLoop sid sref c = finally go (cleanup c sid sref)+      where+        go = do+          msg <- receiveData c+          forkIO $ do+            case decode (BlobData msg) of+              Right (ServerCall nonce method args)+                | Just m <- M.lookup method exports -> do+                  result <- m args sid sref+                  let Blob bs = encode $ ServerReply {+                      srNonce = nonce,+                      srResult = result+                    }+                  sendBinaryData c bs+              Left e -> do+                error $ "Got bad method call: " ++ show msg+          go+#endif++-- | Server monad for Haste.App. Allows redeeming Useless values, lifting IO+--   actions, and not much more.+newtype Server a = Server {unS :: SessionID -> IORef Sessions -> IO a}++instance Functor Server where+  fmap f (Server m) = Server $ \sid ss -> f <$> m sid ss++instance Applicative Server where+  (<*>) = ap+  pure  = return++instance Monad Server where+  return x = Server $ \_ _ -> return x+  (Server m) >>= f = Server $ \sid ss -> do+    Server m' <- f <$> m sid ss+    m' sid ss++instance MonadIO Server where+  liftIO m = Server $ \_ _ -> m++instance MonadBlob Server where+#ifndef __HASTE__+  getBlobData (Blob bd) = return $ BlobData bd+  getBlobText (Blob bd) = return $ BU.toString $ BS.concat $ BSL.toChunks bd+#else+  getBlobData _ = return undefined+  getBlobText _ = return undefined+#endif++-- | Make a Useless value useful by extracting it. Only possible server-side,+--   in the IO monad.+mkUseful :: Useless a -> Server a+mkUseful (Useful x) = return x+mkUseful _          = error "Useless values are only useful server-side!"++-- | Returns the ID of the current session.+getSessionID :: Server SessionID+getSessionID = Server $ \sid _ -> return sid++-- | Return all currently active sessions.+getActiveSessions :: Server Sessions+getActiveSessions = Server $ \_ ss -> readIORef ss
+ libraries/haste-lib/src/Haste/App/Protocol.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}+-- | Haste.App client-server protocol.+module Haste.App.Protocol where+import Control.Applicative+import Control.Exception+import Data.Typeable+import Haste.Binary++type Nonce = Int+type CallID = Int++-- | A method call to the server.+data ServerCall = ServerCall {+    scNonce  :: Nonce,+    scMethod :: CallID,+    scArgs   :: [Blob]+  }++instance Binary ServerCall where+  {-# NOINLINE get #-}+  get = do+    n <- getWord8+    if n == 0+      then ServerCall <$> get <*> get <*> get+      else fail "Wrong magic byte for ServerCall"+  put (ServerCall n c as) = putWord8 0 >> put n >> put c >> put as++-- | A reply to a ServerCall.+data ServerReply = ServerReply {+    srNonce  :: Nonce,+    srResult :: Blob+  }++instance Binary ServerReply where+  {-# NOINLINE get #-}+  get = do+    n <- getWord8+    if n == 1+      then ServerReply <$> get <*> get+      else fail "Wrong magic byte for ServerReply"+  put (ServerReply n r) = putWord8 1 >> put n >> put r++-- | Throw a server exception to the client.+data ServerException = ServerException String deriving (Typeable, Show)+instance Exception ServerException++instance Binary ServerException where+  {-# NOINLINE get #-}+  get = do+    n <- getWord8+    if n == 2+      then ServerException <$> get+      else fail "Wrong magic byte for ServerException"+  put (ServerException e) = putWord8 2 >> put e
+ libraries/haste-lib/src/Haste/Binary.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE MagicHash, CPP, MultiParamTypeClasses, OverloadedStrings,+             TypeSynonymInstances , FlexibleInstances, OverlappingInstances,+             GeneralizedNewtypeDeriving #-}+-- | Handling of Javascript-native binary blobs.+module Haste.Binary (+    module Haste.Binary.Put,+    module Haste.Binary.Get,+    MonadBlob (..), Binary (..),+    Blob, BlobData,+    blobSize, blobDataSize, toByteString, toBlob, strToBlob,+    encode, decode+  )where+import Data.Int+import Data.Word+import Data.Char+import Haste.Prim+import Haste.Concurrent hiding (encode, decode)+import Haste.Foreign+import Haste.Binary.Types+import Haste.Binary.Put+import Haste.Binary.Get+import Control.Applicative++class Monad m => MonadBlob m where+  -- | Retrieve the raw data from a blob.+  getBlobData :: Blob -> m BlobData+  -- | Interpret a blob as UTF-8 text.+  getBlobText :: Blob -> m String++instance MonadBlob CIO where+  getBlobData b = do+      res <- newEmptyMVar+      liftIO $ convertBlob b (toOpaque $ 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 = ffi+        "(function(b,cb){var r=new FileReader();r.onload=function(){A(cb,[new DataView(r.result),0]);};r.readAsArrayBuffer(b);})"++  getBlobText b = do+      res <- newEmptyMVar+      liftIO $ convertBlob b (toOpaque $ concurrent . putMVar res)+      fromJSStr <$> takeMVar res+    where+      convertBlob :: Blob -> Opaque (JSString -> IO ()) -> IO ()+      convertBlob = ffi+        "(function(b,cb){var r=new FileReader();r.onload=function(){A(cb,[[0,r.result],0]);};r.readAsText(b);})"++-- | Somewhat efficient serialization/deserialization to/from binary Blobs.+--   The layout of the binaries produced/read by get/put and encode/decode may+--   change between versions. If you need a stable binary format, you should+--   make your own using the primitives in Haste.Binary.Get/Put.+class Binary a where+  get :: Get a+  put :: a -> Put++instance Binary Word8 where+  put = putWord8+  get = getWord8++instance Binary Word16 where+  put = putWord16le+  get = getWord16le++instance Binary Word32 where+  put = putWord32le+  get = getWord32le++instance Binary Int8 where+  put = putInt8+  get = getInt8++instance Binary Int16 where+  put = putInt16le+  get = getInt16le++instance Binary Int32 where+  put = putInt32le+  get = getInt32le++instance Binary Int where+  put = putInt32le . fromIntegral+  get = fromIntegral <$> getInt32le++instance Binary Float where+  put = putFloat32le+  get = getFloat32le++instance Binary Double where+  put = putFloat64le+  get = getFloat64le++instance (Binary a, Binary b) => Binary (a, b) where+  put (a, b) = put a >> put b+  get = do+    a <- get+    b <- get+    return (a, b)++instance Binary a => Binary (Maybe a) where+  put (Just x) = putWord8 1 >> put x+  put _        = putWord8 0+  get = do+    tag <- getWord8+    case tag of+      0 -> return Nothing+      1 -> Just <$> get+      _ -> fail "Wrong constructor tag when reading Maybe value!"++instance (Binary a, Binary b) => Binary (Either a b) where+  put (Left x)  = putWord8 0 >> put x+  put (Right x) = putWord8 1 >> put x+  get = do+    tag <- getWord8+    case tag of+      0 -> Left <$> get+      1 -> Right <$> get+      _ -> fail "Wrong constructor tag when reading Either value!"++instance Binary () where+  put _ = return ()+  get = return ()++instance Binary a => Binary [a] where+  put xs = do+    putWord32le (fromIntegral $ length xs)+    mapM_ put xs+  get = do+    len <- getWord32le+    flip mapM [1..len] $ \_ -> get++instance Binary Blob where+  {-# NOINLINE put #-}+  put b = do+    put (blobSize b)+    putBlob b+  {-# NOINLINE get #-}+  get = do+    sz <- get+    bd <- getBytes sz+    return $ toBlob bd++instance Binary Char where+  put = put . ord+  get = chr <$> get++encode :: Binary a => a -> Blob+encode x = runPut (put x)++decode :: Binary a => BlobData -> Either String a+decode = runGet get
+ libraries/haste-lib/src/Haste/Binary/Get.hs view
@@ -0,0 +1,166 @@+{-# Language CPP, OverloadedStrings, GeneralizedNewtypeDeriving #-}+module Haste.Binary.Get (+    Get,+    getWord8, getWord16le, getWord32le,+    getInt8, getInt16le, getInt32le,+    getFloat32le, getFloat64le,+    getBytes, skip,+    runGet+  ) where+import Data.Int+import Data.Word+import Haste.Prim+import Haste.Foreign+import Haste.Binary.Types+import Control.Applicative+import Control.Monad+import System.IO.Unsafe+#ifndef __HASTE__+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)}++instance Functor Get where+  fmap f (Get m) = Get $ \buf next -> fmap (fmap f) (m buf next)++instance Applicative Get where+  (<*>) = ap+  pure  = return++instance Monad Get where+  return x = Get $ \_ next -> Right (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++{-# NOINLINE getW8 #-}+getW8 :: Unpacked -> 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)++{-# NOINLINE getW16le #-}+getW16le :: Unpacked -> 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)++{-# NOINLINE getW32le #-}+getW32le :: Unpacked -> 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)++{-# NOINLINE getI8 #-}+getI8 :: Unpacked -> 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)++{-# NOINLINE getI16le #-}+getI16le :: Unpacked -> 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)++{-# NOINLINE getI32le #-}+getI32le :: Unpacked -> 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)++{-# NOINLINE getF32le #-}+getF32le :: Unpacked -> 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)++{-# NOINLINE getF64le #-}+getF64le :: Unpacked -> 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)++getBytes :: Int -> Get BlobData+getBytes len = Get $ \buf next -> Right (next+len, BlobData next len buf)++-- | Skip n bytes of input.+skip :: Int -> Get ()+skip len = Get $ \buf next -> Right (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!"++#else++newtype Get a = Get (BG.Get a) deriving (Functor, Applicative, Monad)++runGet :: Get a -> BlobData -> Either String a+runGet (Get g) (BlobData bd) = unsafePerformIO $ do+  Ex.catch (Right <$> (return $! BG.runGet g bd)) mEx++mEx :: Ex.SomeException -> IO (Either String a)+mEx ex = return . Left $ show ex++getWord8 :: Get Word8+getWord8 = Get BG.getWord8++getWord16le :: Get Word16+getWord16le = Get BG.getWord16le++getWord32le :: Get Word32+getWord32le = Get BG.getWord32le++getInt8 :: Get Int8+getInt8 = Get B.get++getInt16le :: Get Int16+getInt16le = fromIntegral <$> getWord16le++getInt32le :: Get Int32+getInt32le = fromIntegral <$> getWord32le++getFloat32le :: Get Float+getFloat32le = Get BI.getFloat32le++getFloat64le :: Get Double+getFloat64le = Get BI.getFloat64le++getBytes :: Int -> Get BlobData+getBytes len = Get $ do+  bs <- BG.getLazyByteString (fromIntegral len)+  return (BlobData bs)++-- | Skip n bytes of input.+skip :: Int -> Get ()+skip = Get . BG.skip++#endif
+ libraries/haste-lib/src/Haste/Binary/Put.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP, OverloadedStrings, GeneralizedNewtypeDeriving #-}+module Haste.Binary.Put (+    Put, PutM,+    putWord8, putWord16le, putWord32le,+    putInt8, putInt16le, putInt32le,+    putFloat32le, putFloat64le,+    putBlob,+    runPut+  ) where+import Data.Int+import Data.Word+import Haste.Prim+import Haste.Foreign+import Haste.Binary.Types+import Control.Applicative+import Control.Monad+import System.IO.Unsafe+#ifndef __HASTE__+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+newArr :: IO JSArr+newArr = ffi "(function(){return [];})"++push :: Marshal a => JSArr -> a -> IO ()+push = ffi "(function(a,x) {a.push(x);})"++data PutM a = PutM {unP :: JSArr -> IO a}++instance Functor PutM where+  fmap f (PutM m) = PutM $ \a -> fmap f (m a)++instance Applicative PutM where+  (<*>) = ap+  pure  = return++instance Monad PutM where+  return x = PutM $ \_ -> return x+  PutM m >>= f = PutM $ \a -> do+    x <- m a+    unP (f x) a++putWord8 :: Word8 -> Put+putWord8 w = PutM $ \a -> push a (toAB "Uint8Array" 1 w)++putWord16le :: Word16 -> Put+putWord16le w = PutM $ \a -> push a (toAB "Uint16Array" 2 w)++putWord32le :: Word32 -> Put+putWord32le w = PutM $ \a -> push a (toAB "Uint32Array" 4 w)++putInt8 :: Int8 -> Put+putInt8 i = PutM $ \a -> push a (toAB "Int8Array" 1 i)++putInt16le :: Int16 -> Put+putInt16le i = PutM $ \a -> push a (toAB "Int16Array" 2 i)++putInt32le :: Int32 -> Put+putInt32le i = PutM $ \a -> push a (toAB "Int32Array" 4 i)++putFloat32le :: Float -> Put+putFloat32le f = PutM $ \a -> push a (unsafePerformIO $ f2ab f)++{-# NOINLINE f2ab #-}+f2ab :: Float -> IO Unpacked+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 = 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)++toAB :: Marshal a => JSString -> Int -> a -> Unpacked+toAB view size elem = unsafePerformIO $ toABle view size (unpack elem)++{-# NOINLINE toABle #-}+toABle :: Marshal a => JSString -> Int -> a -> IO Unpacked+toABle = ffi "window['toABle']"++-- | 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);})"++#else++newtype PutM a = PutM (BP.PutM a) deriving (Functor, Applicative, Monad)++runPut :: Put -> Blob+runPut (PutM p) = Blob (BP.runPut p)++putWord8 :: Word8 -> Put+putWord8 = PutM . BP.putWord8++putWord16le :: Word16 -> Put+putWord16le = PutM . BP.putWord16le++putWord32le :: Word32 -> Put+putWord32le = PutM . BP.putWord32le++putInt8 :: Int8 -> Put+putInt8 = PutM . B.put++putInt16le :: Int16 -> Put+putInt16le = putWord16le . fromIntegral++putInt32le :: Int32 -> Put+putInt32le = putWord32le . fromIntegral++putFloat32le :: Float -> Put+putFloat32le = PutM . BI.putFloat32le++putFloat64le :: Double -> Put+putFloat64le = PutM . BI.putFloat64le++putBlob :: Blob -> Put+putBlob (Blob b) = PutM $ BP.putLazyByteString b++#endif
+ libraries/haste-lib/src/Haste/Binary/Types.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-}+module Haste.Binary.Types (+    Blob (..), BlobData (..),+    blobSize, blobDataSize, toByteString, toBlob, strToBlob+  ) 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+#endif++#ifdef __HASTE__+data BlobData = BlobData Int Int Unpacked+newtype Blob = Blob Unpacked deriving Marshal++-- | The size, in bytes, of the contents of the given blob.+blobSize :: Blob -> Int+blobSize = unsafePerformIO . ffi "(function(b){return b.size;})"++-- | The size, in bytes, of the contents of the given blob data.+blobDataSize :: BlobData -> Int+blobDataSize (BlobData _ len _) = len++-- | Convert a BlobData to a ByteString. Only usable server-side.+toByteString :: BlobData -> BS.ByteString+toByteString =+  error "Haste.Binary.Types.toByteString called in browser context!"++-- | Convert a piece of BlobData back into a Blob.+toBlob :: BlobData -> Blob+toBlob (BlobData 0 len buf) =+  case newBlob buf of+    b | blobSize b > len -> sliceBlob b 0 len+      | otherwise        -> b+toBlob (BlobData off len buf) =+  sliceBlob (newBlob buf) off (off+len)++-- | Create a Blob from a JSString.+strToBlob :: JSString -> Blob+strToBlob = newBlob . unpack++sliceBlob :: Blob -> Int -> Int -> Blob+sliceBlob b off len = unsafePerformIO $ do+  ffi "(function(b,off,len){return b.slice(off,len);})" b off len++newBlob :: Unpacked -> Blob+newBlob = unsafePerformIO . ffi "(function(b){return new Blob([b]);})"+#else++newtype BlobData = BlobData BS.ByteString+newtype Blob = Blob BS.ByteString++-- Never used except for type checking+instance Marshal BlobData+instance Marshal Blob++-- | The size, in bytes, of the contents of the given blob.+blobSize :: Blob -> Int+blobSize (Blob b) = fromIntegral $ BS.length b++-- | The size, in bytes, of the contents of the given blob data.+blobDataSize :: BlobData -> Int+blobDataSize (BlobData bd) = fromIntegral $ BS.length bd++-- | Convert a BlobData to a ByteString. Only usable server-side.+toByteString :: BlobData -> BS.ByteString+toByteString (BlobData bd) = bd++-- | Convert a piece of BlobData back into a Blob.+toBlob :: BlobData -> Blob+toBlob (BlobData bs) = Blob bs++-- | Create a Blob from a JSString.+strToBlob :: JSString -> Blob+strToBlob s = Blob $ BS.fromChunks [BU.fromString $ fromJSStr s]++#endif
+ libraries/haste-lib/src/Haste/Callback.hs view
@@ -0,0 +1,154 @@+{-# 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 ())++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"++-- | 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)
+ libraries/haste-lib/src/Haste/Compiler.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}+-- | Yo dawg we heard you like Haste, so we let yo Haste programs compile yo+--   Haste programs!+--+--   Currently, this API calls the hastec binary. In the future it should+--   probably be the other way around.+module Haste.Compiler (+    module Haste.Compiler.Flags,+    CompileResult (..), HasteOutput (..), HasteInput (..),+    compile+  ) where+import Haste.Compiler.Flags+#ifndef __HASTE__+import Control.Shell+import Haste.Environment+import Data.Maybe+import Data.List (intercalate)+#endif++data CompileResult = Success HasteOutput | Failure String deriving Show+data HasteOutput = OutFile FilePath | OutString String deriving Show+data HasteInput = InFile FilePath | InString String deriving Show++-- | Compile a Haste program using the given compiler flags and source+--   directory.+--   Calling this function from the client will always result in failure.+compile :: CompileFlags -> FilePath -> HasteInput -> IO CompileResult+#ifdef __HASTE__+compile _ _ _ = return $ Failure "Haste can only compile programs server-side."+#else+compile cf dir inp = do+  res <- shell $ do+    curdir <- pwd+    inTempDirectory $ do+      f <- 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) ""+      if not f+        then do+          return $ Failure e+        else do+          case cfTarget cf of+            TargetFile f -> do+              return $ Success $ OutFile f+            TargetString -> do+              (Success . OutString) `fmap` file "haste.out"+  case res of+    Right res ->+      return res+    Left e ->+      return $ Failure $ "Run-time failure during compilation: " ++ e+  where+    incdir cur = if isRelative dir then cur </> dir else dir+    idir cur = "-i" ++ incdir cur++-- | Turn flags into command line argument.+mkFlags :: CompileFlags -> [String]+mkFlags cf = catMaybes [+    case cfOptimize cf of+      None         -> Just "-O0"+      Basic        -> Nothing+      WholeProgram -> Just "--opt-whole-program",+    case cfStart cf of+      ASAP     -> Just "--start=asap"+      OnLoad   -> Nothing+      Custom s -> Just $ "--start=" ++ s,+    case cfTarget cf of+      TargetFile fp -> Just $ "--out=" ++ fp+      TargetString  -> Just $ "--out=haste.out",+    when cfDebug        "--debug",+    when cfMinify       "--opt-google-closure",+    when cfFullUnicode  "--full-unicode",+    when cfOwnNamespace "--separate-namespace",+    when (not . null . cfJSFiles) ("--with-js=" ++ jsFileList)+  ]+  where+    jsFileList = intercalate "," $ cfJSFiles cf+    when opt arg = if opt cf then Just arg else Nothing+#endif
+ libraries/haste-lib/src/Haste/Compiler/Flags.hs view
@@ -0,0 +1,53 @@+module Haste.Compiler.Flags (+    OptLevel (..), ProgStart (..), HasteTarget (..), CompileFlags,+    cfOptimize, cfDebug, cfMinify, cfFullUnicode, cfOwnNamespace, cfStart,+    cfJSFiles, cfTarget+  ) where+import Data.Default++data OptLevel = None | Basic | WholeProgram+data ProgStart = ASAP | OnLoad | Custom String+data HasteTarget = TargetFile FilePath | TargetString++-- | Flags to pass to the compiler. Defaults are the same as when invoking+--   hastec directly. Consult hastec --help for more detailed descriptions.+data CompileFlags = CompileFlags {+    -- | How much should the given program be optimized?+    --   Default: Basic+    cfOptimize     :: OptLevel,+    -- | Should the output be debuggable? Debug information will be stripped+    --   if the program is minified using Closure.+    --   Default: False+    cfDebug        :: Bool,+    -- | Should the program be minified? This will strip any debug information+    --   from the resulting program.+    --   Default: False+    cfMinify       :: Bool,+    -- | Use full Unicode compatibility for Data.Char and friends?+    --   Default: False+    cfFullUnicode  :: Bool,+    -- | Put generated code in a separate namespace?+    --   Default: False+    cfOwnNamespace :: Bool,+    -- | How should the program be started?+    --   Default: OnLoad+    cfStart        :: ProgStart,+    -- | Javascript files to include in the final program.+    --   Default: []+    cfJSFiles      :: [FilePath],+    -- | Where to place the compilation output.+    --   Default: TargetString+    cfTarget       :: HasteTarget+  }++instance Default CompileFlags where+  def = CompileFlags {+      cfOptimize = Basic,+      cfDebug = False,+      cfMinify = False,+      cfFullUnicode = False,+      cfOwnNamespace = False,+      cfStart = OnLoad,+      cfJSFiles = [],+      cfTarget = TargetString+    }
+ libraries/haste-lib/src/Haste/Concurrent.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}+-- | Concurrency for Haste. Includes MVars, forking, Ajax and more.+module Haste.Concurrent (module Monad, module Ajax, wait, server) where+import Haste.Concurrent.Monad as Monad+import Haste.Concurrent.Ajax as Ajax+import Haste.Callback++-- | Wait for n milliseconds.+wait :: Int -> CIO ()+wait ms = do+  v <- newEmptyMVar+  liftIO $ setTimeout' ms $ putMVar v ()+  takeMVar v++-- | Creates a generic server thread. A server is a function taking a state+--   and an event argument, returning an updated state or Nothing.+--   @server@ creates an MVar that is used to pass events to the server.+--   Whenever a value is written to this MVar, that value is passed to the+--   server function togeter with its current state.+--   If the server function returns Nothing, the server thread terminates.+--   If it returns a new state, the server again blocks on the event MVar,+--   and will use the new state to any future calls to the server function.+server :: state -> (state -> evt -> CIO (Maybe state)) -> CIO (MVar evt)+server initialState handler = do+    evtvar <- newEmptyMVar+    forkIO $ loop evtvar initialState+    return evtvar+  where+    loop m st = do+      mresult <- takeMVar m >>= handler st+      case mresult of+        Just st' -> loop m st'+        _        -> return ()++instance GenericCallback (CIO ()) CIO where+  type CB (CIO ()) = IO ()+  mkcb toIO m = toIO m+  mkIOfier _ = return concurrent
+ libraries/haste-lib/src/Haste/Concurrent/Ajax.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-}+-- | Concurrent Ajax calls. IE6 and older are not supported.+module Haste.Concurrent.Ajax (+    Key, Val, JSON (..), (!), (~>), Method (..), URL, AjaxData (..),+    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]
+ libraries/haste-lib/src/Haste/Concurrent/Monad.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances, FlexibleContexts, CPP #-}+-- | Implements concurrency for Haste based on "A Poor Man's Concurrency Monad".+module Haste.Concurrent.Monad (+    MVar, CIO, ToConcurrent (..), MonadConc (..),+    forkIO, forkMany, newMVar, newEmptyMVar, takeMVar, putMVar, withMVarIO,+    peekMVar, modifyMVarIO, concurrent, liftIO+  ) where+import Control.Monad.IO.Class+import Control.Monad.Cont.Class+import Control.Monad+import Control.Applicative+import Data.IORef++-- | Any monad which supports concurrency.+class MonadConc m where+  liftConc :: CIO a -> m a++instance MonadConc CIO where+  liftConc = id++-- | Embed concurrent computations into non-concurrent ones.+class ToConcurrent a where+  type Async a+  async :: Async a -> a++instance ToConcurrent (IO ()) where+  type Async (IO ()) = CIO ()+  async = concurrent++instance ToConcurrent (CIO ()) where+  type Async (CIO ()) = CIO ()+  async = id++instance ToConcurrent b => ToConcurrent (a -> b) where+  type Async (a -> b) = a -> Async b+  async f = \x -> async (f x)++data MV a+  = Full a [(a, CIO ())] -- A full MVar: a queue of writers+  | Empty  [a -> CIO ()] -- An empty MVar: a queue of readers+newtype MVar a = MVar (IORef (MV a))++data Action where+  Atom :: IO Action -> Action+  Fork :: [Action] -> Action+  Stop :: Action++-- | Concurrent IO monad. The normal IO monad does not have concurrency+--   capabilities with Haste. This monad is basically IO plus concurrency.+newtype CIO a = C {unC :: (a -> Action) -> Action}++instance Monad CIO where+  return x    = C $ \next -> next x+  (C m) >>= f = C $ \b -> m (\a -> unC (f a) b)++instance Functor CIO where+  fmap f m = do+    x <- m+    return $ f x++instance Applicative CIO where+  (<*>) = ap+  pure  = return++instance MonadIO CIO where+  liftIO m = C $ \next -> Atom (fmap next m)++instance MonadCont CIO where+  callCC f = C $ \next -> unC (f (\a -> C $ \_ -> next a)) next++-- | Spawn a new thread.+forkIO :: CIO () -> CIO ()+forkIO (C m) = C $ \next -> Fork [next (), m (const Stop)]++-- | Spawn several threads at once.+forkMany :: [CIO ()] -> CIO ()+forkMany ms = C $ \next -> Fork (next () : [act (const Stop) | C act <- ms])++-- | Create a new MVar with an initial value.+newMVar :: MonadIO m => a -> m (MVar a)+newMVar a = liftIO $ MVar `fmap` newIORef (Full a [])++-- | Create a new empty MVar.+newEmptyMVar :: MonadIO m => m (MVar a)+newEmptyMVar = liftIO $ MVar `fmap` newIORef (Empty [])++-- | Read an MVar. Blocks if the MVar is empty.+--   Only the first writer in the write queue, if any, is woken.+takeMVar :: MVar a -> CIO a+takeMVar (MVar ref) =+  callCC $ \next -> join $ liftIO $ do+    v <- readIORef ref+    case v of+      Full x ((x',w):ws) -> do+        writeIORef ref (Full x' ws)+        return $ forkIO w >> return x+      Full x _ -> do+        writeIORef ref (Empty [])+        return $ return x+      Empty rs -> do+        writeIORef ref (Empty (rs ++ [next]))+        return $ C (const Stop)++-- | Peek at the value inside a given MVar, if any, without removing it.+peekMVar :: MonadIO m => MVar a -> m (Maybe a)+peekMVar (MVar ref) = liftIO $ do+  v <- readIORef ref+  case v of+    Full x _ -> return (Just x)+    _        -> return Nothing++-- | Write an MVar. Blocks if the MVar is already full.+--   Only the first reader in the read queue, if any, is woken.+putMVar :: MVar a -> a -> CIO ()+putMVar (MVar ref) x =+  callCC $ \next -> join $ liftIO $ do+    v <- readIORef ref+    case v of+      Full oldx ws -> do+        writeIORef ref (Full oldx (ws ++ [(x, next ())]))+        return $ C (const Stop)+      Empty (r:rs) -> do+        writeIORef ref (Empty rs)+        return $ forkIO (r x)+      Empty _ -> do+        writeIORef ref (Full x [])+        return $ next ()++-- | Perform an IO action over an MVar.+withMVarIO :: MVar a -> (a -> IO b) -> CIO b+withMVarIO v m = takeMVar v >>= liftIO . m++-- | Perform an IO action over an MVar, then write the MVar back.+modifyMVarIO :: MVar a -> (a -> IO (a, b)) -> CIO b+modifyMVarIO v m = do+  (x, res) <- withMVarIO v m+  putMVar v x+  return res++-- | Run a concurrent computation. Two different concurrent computations may+--   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) =+      case p of+        Atom io -> do+          next <- io+          scheduler (ps ++ [next])+        Fork ps' -> do+          scheduler (ps ++ ps')+        Stop -> do+          scheduler ps+    scheduler _ =+      return ()+#else+concurrent = error "concurrent called in a non-browser environment!"+#endif
+ libraries/haste-lib/src/Haste/DOM.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP #-}+module Haste.DOM (+    Elem (..), PropID, ElemID,+    newElem, newTextElem,+    elemById, setProp, getProp, setAttr, getAttr, setProp',+    getProp', getValue, withElem , withElems, addChild,+    addChildBefore, removeChild, clearChildren , getChildBefore,+    getLastChild, getChildren, setChildren , getStyle, setStyle,+    getStyle', setStyle',+    getFileData, getFileName+  ) where+import Haste.Prim+import Haste.JSType+import Data.Maybe (isNothing, fromJust)+import Control.Monad.IO.Class+import Haste.Foreign+import Haste.Binary.Types++newtype Elem = Elem JSAny+instance Marshal Elem++type PropID = String+type ElemID = String++#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 jsCreateElem :: JSString -> IO Elem+foreign import ccall jsCreateTextNode :: JSString -> IO Elem+foreign import ccall jsAppendChild :: Elem -> Elem -> IO ()+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!"+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!"+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 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++-- | Create a text node.+newTextElem :: MonadIO m => String -> m Elem+newTextElem = liftIO . jsCreateTextNode . 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++-- | 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"++-- | 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++-- | Get an attribute of an element.+getAttr :: MonadIO m => Elem -> PropID -> m String+getAttr e prop = liftIO $ fromJSStr `fmap` jsGetAttr e (toJSStr prop)++-- | 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++-- | 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++-- | Get an element by its HTML ID attribute.+elemById :: MonadIO m => ElemID -> m (Maybe Elem)+elemById eid = liftIO $ fromPtr `fmap` (jsFind $ toJSStr eid)++-- | 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!"++-- | 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 _ _                  = []++-- | 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+    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 :: 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
+ libraries/haste-lib/src/Haste/Foreign.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances,+             FlexibleInstances, TypeFamilies, OverlappingInstances, CPP,+             OverloadedStrings #-}+-- | Create functions on the fly from JS strings.+--   Slower but more flexible alternative to the standard FFI.+module Haste.Foreign (+    FFI, Marshal (..), Unpacked, Opaque, ffi, export, toOpaque, fromOpaque+  ) where+import Haste.Prim+import Haste.JSType+import Data.Word+import Data.Int+import System.IO.Unsafe+import Unsafe.Coerce++#ifdef __HASTE__+foreign import ccall eval :: JSString -> IO (Ptr a)+foreign import ccall "String" jsString :: Double -> JSString+#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!"+#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 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 Marshal a where+  pack :: Unpacked -> a+  pack = unsafePack++  unpack :: a -> Unpacked+  unpack = unsafeUnpack++instance Marshal Float+instance Marshal Double+instance Marshal JSString where+  pack = jsString . unsafePack+instance Marshal Int where+  pack x = convert (unsafePack x :: Double)+instance Marshal Int8 where+  pack x = convert (unsafePack x :: Double)+instance Marshal Int16 where+  pack x = convert (unsafePack x :: Double)+instance Marshal Int32 where+  pack x = convert (unsafePack x :: Double)+instance Marshal Word where+  pack x = convert (unsafePack x :: Double)+instance Marshal Word8 where+  pack x = convert (unsafePack x :: Double)+instance Marshal Word16 where+  pack x = convert (unsafePack x :: Double)+instance Marshal Word32 where+  pack x = convert (unsafePack x :: Double)+instance Marshal () where+  pack _   = ()+  unpack _ = unpack (0 :: Double)+instance Marshal String where+  pack = fromJSStr . pack+  unpack = unpack . toJSStr+instance Marshal Unpacked where+  pack = id+  unpack = id+instance Marshal (Opaque a) where+  pack = Opaque+  unpack (Opaque x) = x+instance Marshal Bool where+  unpack True  = jsTrue+  unpack False = jsFalse+  pack x = if pack x > (0 :: Double) then True else False++-- | Lists are marshalled into arrays.+instance Marshal a => Marshal [a] where+  unpack = lst2arr . toOpaque . map unpack+  pack arr = map pack . fromOpaque $ arr2lst arr 0++{-# 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 "lst2arr" arr ix++-- | Maybe is simply a nullable type. Nothing is equivalent to null, and any+--   non-null value is equivalent to x in Just x.+instance Marshal a => Marshal (Maybe a) where+  unpack Nothing  = jsNull+  unpack (Just x) = unpack x+  pack x = if isNull x then Nothing else Just (pack x)++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;})"++class FFI a where+  type T a+  unpackify :: T a -> a+  -- | TODO: although the @export@ function, which is the only user-visible+  --         interface to @packify@, is type safe, the function itself is not.+  --         This should be fixed ASAP!+  packify :: a -> a++instance Marshal a => FFI (IO a) where+  type T (IO a) = IO Unpacked+  unpackify = fmap pack+  packify m = fmap (unsafeCoerce . unpack) m++instance (Marshal a, FFI b) => FFI (a -> b) where+  type T (a -> b) = Unpacked -> T b+  unpackify f x = unpackify (f $! unpack x)+  packify f x = packify (f $! pack (unsafeCoerce x))++-- | 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.+--+--   For instance, the following WILL cause crazy behavior due to wrong types:+--   ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int+--+--   In other words, this function is completely unsafe - use with caution.+--+--   ALWAYS use type signatures for functions defined using this function, as+--   the argument marshalling is decided by the type signature.+ffi :: FFI a => JSString -> a+ffi = unpackify . unsafeEval++-- | 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+--   to access your exports through Haste[\'name\'](), or Closure will mangle+--   your function names.+export :: FFI a => JSString -> a -> IO ()+export name f =+    ffi (toJSStr $ "(function(s, f) {" +++         "  Haste[s] = function() {" +++         "      var args = Array.prototype.slice.call(arguments,0);" +++         "      args.push(0);" +++         "      return E(A(f, args));" +++         "    };" +++         "  return 0;" +++         "})") name f'+  where+    f' :: Unpacked+    f' = unsafeCoerce $! packify f++unsafeUnpack :: a -> Unpacked+unsafeUnpack x =+  case unsafeCoerce x of+    Dummy x' -> x'++unsafePack :: Unpacked -> a+unsafePack = unsafeCoerce . Dummy++unsafeEval :: JSString -> a+unsafeEval s = unsafePerformIO $ do+  x <- eval s+  return $ fromPtr x
+ libraries/haste-lib/src/Haste/Graphics/Canvas.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings,+             TypeSynonymInstances, FlexibleInstances, GADTs, CPP #-}+-- | Basic Canvas graphics library.+module Haste.Graphics.Canvas (+  -- Types+  Bitmap, Canvas, Shape, Picture, Point, Vector, Angle, Rect (..), Color (..),+  AnyImageBuffer (..),+  -- Classes+  ImageBuffer (..), BitmapSource (..),+  -- Obtaining a canvas for drawing+  getCanvasById, getCanvas, createCanvas,+  -- Working with bitmaps+  bitmapElem,+  -- Rendering pictures, extracting data from a canvas+  render, buffer, toDataURL,+  -- Working with colors and opacity+  setStrokeColor, setFillColor, color, opacity,+  -- Matrix operations+  translate, scale, rotate,+  -- Using shapes+  stroke, fill, clip,+  -- Creating shapes+  line, path, rect, circle, arc,+  -- Working with text+  font, text+  ) where+import Control.Applicative+import Control.Monad.IO.Class+import Haste+import Haste.Concurrent (CIO) -- for SPECIALISE pragma++#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 = 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++newtype Bitmap = Bitmap Elem++-- | Any type that contains a buffered image which can be drawn onto a canvas.+class ImageBuffer a where+  -- | Draw the image buffer with its top left corner at the specified point.+  draw :: a -> Point -> Picture ()+  -- | Draw a portion of the image buffer with its top left corner at the+  --   specified point.+  drawClipped :: a -> Point -> 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++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++-- | Any type that can be used to obtain a bitmap.+class BitmapSource src where+  -- | Load a bitmap from some kind of bitmap source.+  loadBitmap :: MonadIO m => src -> m Bitmap++instance BitmapSource URL where+  loadBitmap url = liftIO $ do+    img <- newElem "img"+    setProp img "src" url+    loadBitmap img++instance BitmapSource Elem where+  loadBitmap = return . Bitmap++data AnyImageBuffer where+  AnyImageBuffer :: ImageBuffer a => a -> AnyImageBuffer++instance ImageBuffer AnyImageBuffer where+  draw (AnyImageBuffer buf) = draw buf+  drawClipped (AnyImageBuffer buf) = drawClipped buf++-- | Get the HTML element associated with the given bitmap.+bitmapElem :: Bitmap -> Elem+bitmapElem (Bitmap e) = e++-- | A point in the plane.+type Point = (Double, Double)++-- | A two dimensional vector.+type Vector = (Double, Double)++-- | An angle, given in radians.+type Angle = Double++-- | A rectangle.+data Rect = Rect {rect_x :: Double,+                  rect_y :: Double,+                  rect_w :: Double,+                  rect_h :: Double}++-- | A color, specified using its red, green and blue components, with an+--   optional alpha component.+data Color = RGB Int Int Int+           | RGBA Int Int Int Double++-- | Somewhat efficient conversion from Color to JSString.+color2JSString :: Color -> JSString+color2JSString (RGB r g b) =+  catJSStr "" ["rgb(", toJSString r, ",", toJSString g, ",", toJSString b, ")"]+color2JSString (RGBA r g b a) =+  catJSStr "" ["rgba(", toJSString r, ",",+                        toJSString g, ",",+                        toJSString b, ",",+                        toJSString a, ")"]++-- | A drawing context; part of a canvas.+newtype Ctx = Ctx JSAny++-- | 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+--   corner of the canvas element.+data Canvas = Canvas Ctx Elem++-- | A picture that can be drawn onto a canvas.+newtype Picture a = Picture {unP :: Ctx -> IO a}++-- | A shape which can be either stroked or filled to yield a picture.+newtype Shape a = Shape {unS :: Ctx -> IO a}++instance Monad Picture where+  return x = Picture $ \_ -> return x+  Picture m >>= f = Picture $ \ctx -> do+    x <- m ctx+    unP (f x) ctx++instance Monad Shape where+  return x = Shape $ \_ -> return x+  Shape m >>= f = Shape $ \ctx -> do+    x <- m ctx+    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 eid = liftIO $ do+  e <- elemById eid+  maybe (return Nothing) getCanvas e++-- | Create a 2D drawing context from a DOM element.+getCanvas :: MonadIO m => Elem -> m (Maybe Canvas)+getCanvas e = liftIO $ do +  hasCtx <- jsHasCtx2D e+  case hasCtx of+    True -> do+      ctx <- jsGetCtx2D e+      return $ Just $ Canvas ctx e+    _    -> return Nothing++-- | Create an off-screen buffer of the specified size.+createCanvas :: Int -> Int -> IO (Maybe Canvas)+createCanvas w h = do+  buf <- newElem "canvas"+  setProp buf "width" (toString w)+  setProp buf "height" (toString h)+  getCanvas buf++-- | Clear a canvas, then draw a picture onto it.+{-# SPECIALISE render :: Canvas -> Picture a -> IO a #-}+{-# SPECIALISE render :: Canvas -> Picture a -> CIO a #-}+render :: MonadIO m => Canvas -> Picture a -> m a+render (Canvas ctx el) (Picture p) = liftIO $ do+  jsResetCanvas el+  p ctx++-- | Generate a data URL from the contents of a canvas.+toDataURL :: MonadIO m => Canvas -> m URL+toDataURL (Canvas _ el) = liftIO $ do+  fromJSStr <$> jsCanvasToDataURL el++-- | 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"++-- | Set a new color for strokes.+setStrokeColor :: Color -> Picture ()+setStrokeColor c = Picture $ \(Ctx ctx) -> do+  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)++-- | 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)+  pict (Ctx ctx)+  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'+    pict (Ctx ctx)+    setProp' (Elem ctx) "fillStyle" fc+    setProp' (Elem ctx) "strokeStyle" sc+  where+    c' = color2JSString c++-- | Draw the specified picture using the given point as the origin.+translate :: Vector -> Picture () -> Picture ()+translate (x, y) (Picture pict) = Picture $ \ctx -> do+  jsPushState ctx+  jsTranslate ctx x y+  pict ctx+  jsPopState ctx++-- | Draw the specified picture rotated @r@ radians clockwise.+rotate :: Double -> Picture () -> Picture ()+rotate rad (Picture pict) = Picture $ \ctx -> do+  jsPushState ctx+  jsRotate ctx rad+  pict ctx+  jsPopState ctx++-- | Draw the specified picture scaled as specified by the scale vector.+scale :: Vector -> Picture () -> Picture ()+scale (x, y) (Picture pict) = Picture $ \ctx -> do+  jsPushState ctx+  jsScale ctx x y+  pict ctx+  jsPopState ctx++-- | Draw a filled shape.+fill :: Shape () -> Picture ()+fill (Shape shape) = Picture $ \ctx -> do+  jsBeginPath ctx+  shape ctx+  jsFill ctx+  +-- | Draw the contours of a shape.+stroke :: Shape () -> Picture ()+stroke (Shape shape) = Picture $ \ctx -> do+  jsBeginPath ctx+  shape ctx+  jsStroke ctx++-- | Draw a picture clipped to the given path.+clip :: Shape () -> Picture () -> Picture ()+clip (Shape shape) (Picture pict) = Picture $ \ctx -> do+  jsPushState ctx+  jsBeginPath ctx+  shape ctx+  jsClip ctx+  pict ctx+  jsPopState ctx++-- | Draw a path along the specified points.+path :: [Point] -> Shape ()+path ((x1, y1):ps) = Shape $ \ctx -> do+  jsMoveTo ctx x1 y1+  mapM_ (uncurry $ jsLineTo ctx) ps+path _ =+  return ()++-- | Draw a line between two points.+line :: Point -> Point -> Shape ()+line p1 p2 = path [p1, p2]++-- | Draw a rectangle between the two given points.+rect :: Point -> Point -> Shape ()+rect (x1, y1) (x2, y2) = path [(x1, y1), (x2, y1), (x2, y2), (x1, y2), (x1, y1)]++-- | Draw a circle shape.+circle :: Point -> Double -> Shape ()+circle (x, y) radius = Shape $ \ctx -> do+  jsMoveTo ctx (x+radius) y+  jsArc ctx x y radius (0 :: Double) twoPi++{-# INLINE twoPi #-}+twoPi :: Double+twoPi = 2*pi++-- | Draw an arc. An arc is specified as a drawn portion of an imaginary+--   circle with a center point, a radius, a starting angle and an ending+--   angle.+--   For instance, @arc (0, 0) 10 0 pi@ will draw a half circle centered at+--   (0, 0), with a radius of 10 pixels.+arc :: Point -> Double -> Angle -> Angle -> Shape ()+arc (x, y) radius from to = Shape $ \ctx -> jsArc ctx x y radius from to++-- | 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)+  pict (Ctx ctx)+  setProp' (Elem ctx) "font" f'++-- | Draw some text onto the canvas.+text :: Point -> String -> Picture ()+text (x, y) str = Picture $ \ctx -> jsDrawText ctx (toJSString str) x y
+ libraries/haste-lib/src/Haste/Hash.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, GADTs, OverloadedStrings #-}+-- | Hash manipulation and callbacks.+module Haste.Hash (onHashChange, setHash, getHash) 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 Marshal HashCallback where+  pack = unsafeCoerce+  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 f = do+    f' <- toCallback $ \old new -> f (fromJSStr old) (fromJSStr new)+    liftIO $ go (HashCallback f')+  where+    go :: HashCallback -> IO ()+    go = ffi "(function(cb) {\+             \  window.onhashchange = function(e){\+             \      A(cb, [[0,e.oldURL.split('#')[1] || ''],\+             \             [0,e.newURL.split('#')[1] || ''],0]);\+             \    };\+             \})"++-- | Set the hash part of the current URL.+setHash :: MonadIO m => String -> m ()+setHash = liftIO . ffi "(function(h) {location.hash = '#'+h;})"++-- | Read the hash part of the currunt URL.+getHash :: MonadIO m => m String+getHash = liftIO $ ffi "(function() {return location.hash.substring(1);})"
+ libraries/haste-lib/src/Haste/JSON.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, PatternGuards, +             FlexibleInstances, CPP #-}+-- | Haste-specific JSON library. JSON is common enough that it's a good idea+--   to create as fast and small an implementation as possible. To that end,+--   the parser is implemented entirely in Javascript, and works with any+--   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, (!), (~>)) where+import Haste.Prim+import Data.String as S+#ifndef __HASTE__+import Haste.Parsing+import Control.Applicative+import Data.Char (ord)+import Numeric (showHex)+#endif++-- Remember to update jsParseJSON if this data type changes!+data JSON+  = Num  Double+  | Str  JSString+  | Bool Bool+  | Arr  [JSON]+  | Dict [(JSString, JSON)]++instance IsString JSON where+  fromString = Str . S.fromString++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+--   objects using plain numeric literals.+instance Num JSON where+  (Num a) + (Num b) = Num (a+b)+  _ + _             = numFail+  (Num a) * (Num b) = Num (a*b)+  _ * _             = numFail+  (Num a) - (Num b) = Num (a-b)+  _ - _             = numFail+  negate (Num a)    = Num (negate a)+  negate _          = numFail+  abs (Num a)       = Num (abs a)+  abs _             = numFail+  signum (Num a)    = signum (Num a)+  signum _          = numFail+  fromInteger n     = Num (fromInteger n)++#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)+#else+jsShowD :: Double -> JSString+jsShowD = toJSStr . show++jsStringify :: JSString -> JSString+jsStringify = toJSStr . ('"' :) . unq . fromJSStr+  where+    unq ('"' : cs) = "\\\"" ++ unq cs+    unq (c : cs)+      | c < ' ' || c > '~' = unicodeChar c (unq cs)+      | c == '\\'          = "\\\\" ++ unq cs+      | otherwise          = c : unq cs+    unq _          = ['"']++    unicodeChar c str =+      case showHex (ord c) "" of+        s -> "\\u" ++ replicate (4-length s) '0' ++ s ++ str+#endif++-- | Look up a JSON object from a JSON dictionary. Panics if the dictionary+--   isn't a dictionary, or if it doesn't contain the given key.+(!) :: JSON -> JSString -> JSON+dict ! k =+  case dict ~> k of+    Just x -> x+    _      -> error $ "Haste.JSON.!: unable to look up key " ++ fromJSStr k+infixl 5 !++class JSONLookup a where+  -- | Look up a key in a JSON dictionary. Return Nothing if the key can't be+  --   found for some reason.+  (~>) :: a -> JSString -> Maybe JSON  +infixl 5 ~>++instance JSONLookup JSON where+  (Dict m) ~> key = lookup key m+  _        ~> _   = Nothing++instance JSONLookup (Maybe JSON) where+  (Just (Dict m)) ~> key = lookup key m+  _               ~> _   = Nothing++encodeJSON :: JSON -> JSString+encodeJSON = catJSStr "" . enc []+  where+    comma   = ","+    openbr  = "["+    closebr = "]"+    opencu  = "{"+    closecu = "}"+    colon   = ":"+    quote   = "\""+    true    = "true"+    false   = "false"+    enc acc (Str s)      = jsStringify s : acc+    enc acc (Num d)      = jsShowD d : acc+    enc acc (Bool True)  = true : acc+    enc acc (Bool False) = false : acc+    enc acc (Arr elems)+      | (x:xs) <- elems =+        openbr : enc (foldr (\s a -> comma:enc a s) (closebr:acc) xs) x+      | otherwise =+        openbr : closebr : acc+    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+        in encAll+      | otherwise =+        opencu : closecu : acc++decodeJSON :: JSString -> Either String JSON+#ifdef __HASTE__+decodeJSON = liftMaybe . fromPtr . jsParseJSON+  where+    liftMaybe (Just x) = Right x+    liftMaybe _        = Left "Invalid JSON!"+#else+decodeJSON = liftMaybe . runParser json . fromJSStr+  where+    liftMaybe (Just x) = Right x+    liftMaybe _        = Left "Invalid JSON!"+    json = oneOf [Num  <$> double,+                  Bool <$> boolean,+                  Str  <$> jsstring,+                  Arr  <$> array,+                  Dict <$> object]+    jsstring = toJSStr <$> oneOf [quotedString '\'', quotedString '"']+    boolean = oneOf [string "true" >> pure True, string "false" >> pure False]+    array = do+      char '[' >> possibly whitespace+      elements <- commaSeparated json+      possibly whitespace >> char ']'+      return elements+    commaSeparated p =+      oneOf [do x <- p+                possibly whitespace >> char ',' >> possibly whitespace+                xs <- commaSeparated p+                return (x:xs),+             do x <- p+                return [x],+             do return []]+    object = do+      char '{' >> possibly whitespace+      pairs <- commaSeparated kvPair+      possibly whitespace >> char '}'+      return pairs+    kvPair = do+      k <- jsstring+      possibly whitespace >> char ':' >> possibly whitespace+      v <- json+      return (k, v)+#endif++instance Show JSON where+  show = fromJSStr . encodeJSON
+ libraries/haste-lib/src/Haste/JSType.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE MultiParamTypeClasses, ForeignFunctionInterface, MagicHash, +             TypeSynonymInstances, FlexibleInstances, EmptyDataDecls,+             UnliftedFFITypes, UndecidableInstances, CPP #-}+-- | 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)+#ifdef __HASTE__+import GHC.Prim+import GHC.Integer.GMP.Internals+import GHC.Types (Int (..))+#else+import GHC.Float+#endif++class JSType a where+  toJSString   :: a -> JSString+  fromJSString :: JSString -> Maybe a++-- | (Almost) all numeric types can be efficiently converted to and from+--   Double, which is the internal representation for most of them.+class JSNum a where+  toNumber   :: a -> Double+  fromNumber :: Double -> a++#ifdef __HASTE__++foreign import ccall "Number" jsNumber          :: JSString -> Double+foreign import ccall "String" jsString          :: Double -> JSString+foreign import ccall jsRound                    :: Double -> Int+foreign import ccall "I_toInt" jsIToInt         :: ByteArray# -> Int+foreign import ccall "I_toString" jsIToString   :: ByteArray# -> JSString+foreign import ccall "I_fromString" jsStringToI :: JSString -> ByteArray#+foreign import ccall "I_fromNumber" jsNumToI    :: ByteArray# -> ByteArray#++unsafeToJSString :: a -> JSString+unsafeToJSString = unsafeCoerce# jsString++unsafeIntFromJSString :: JSString -> Maybe a+unsafeIntFromJSString s =+    case jsNumber s of+      d | isNaN d   -> Nothing+        | otherwise -> Just (unsafeCoerce# (jsRound d))++-- JSNum instances++instance JSNum Int where+  fromNumber = unsafeCoerce# jsRound+  toNumber = unsafeCoerce#++instance JSNum Int8 where+  fromNumber n = case fromNumber n of I# n' -> I8# (narrow8Int# n')+  toNumber = unsafeCoerce#++instance JSNum Int16 where+  fromNumber n = case fromNumber n of I# n' -> I16# (narrow16Int# n')+  toNumber = unsafeCoerce#++instance JSNum Int32 where+  fromNumber = unsafeCoerce# jsRound+  toNumber = unsafeCoerce#++instance JSNum Word where+  fromNumber n =+    case jsRound (unsafeCoerce# n) of+      I# n' -> W# (int2Word# n')+  toNumber = unsafeCoerce#++instance JSNum Word8 where+  fromNumber w = case fromNumber w of W# w' -> W8# (narrow8Word# w')+  toNumber = unsafeCoerce#++instance JSNum Word16 where+  fromNumber w = case fromNumber w of W# w' -> W16# (narrow16Word# w')+  toNumber = unsafeCoerce#++instance JSNum Word32 where+  fromNumber w = case fromNumber w of W# w' -> W32# w'+  toNumber = unsafeCoerce#++instance JSNum Integer where+  toNumber (S# n) = toNumber (I# n)+  toNumber (J# n) = unsafeCoerce# (jsIToInt n)+  fromNumber n    = J# (jsNumToI (unsafeCoerce# n))++instance JSNum Float where+  fromNumber = unsafeCoerce#+  toNumber = unsafeCoerce#++instance JSNum Double where+  fromNumber = id+  toNumber = id++-- JSType instances+-- TODO: fromJSString is unsafe for Words; they may end up negative! fix asap!+instance JSType Int where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString+instance JSType Int8 where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString+instance JSType Int16 where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString+instance JSType Int32 where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString+instance JSType Word where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString+instance JSType Word8 where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString+instance JSType Word16 where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString+instance JSType Word32 where+  toJSString = unsafeToJSString+  fromJSString = unsafeIntFromJSString++instance JSType Float where+  fromJSString s =+    case jsNumber s of+      d | isNaN d   -> Nothing+        | otherwise -> Just (unsafeCoerce# d)+  toJSString = unsafeToJSString++instance JSType Double where+  fromJSString s =+    case jsNumber s of+      d | isNaN d   -> Nothing+        | otherwise -> Just d+  toJSString = unsafeToJSString++-- This is completely insane, but GHC for some reason pukes when we try to+-- use the constructors of the actual integers, so we coerce them into this+-- isomorphic type to work with them instead.+data Dummy = Small Int# | Big ByteArray#++instance JSType Integer where+  toJSString n =+    case unsafeCoerce# n of+      Small n' -> toJSString (I# n')+      Big n'   -> jsIToString n'+  fromJSString s =+    case jsStringToI s of+      n -> Just (unsafeCoerce# (Big n))++instance JSType String where+  toJSString     = toJSStr+  fromJSString   = Just . fromJSStr++instance JSType () where+  toJSString _ = toJSStr "()"+  fromJSString s | s == toJSStr "()" = Just ()+                 | otherwise = Nothing++#else++instance JSNum Int where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Int8 where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Int16 where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Int32 where+  toNumber = fromIntegral+  fromNumber = round++instance JSNum Word where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Word8 where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Word16 where+  toNumber = fromIntegral+  fromNumber = round+instance JSNum Word32 where+  toNumber = fromIntegral+  fromNumber = round++instance JSNum Double where+  toNumber = id+  fromNumber = id+instance JSNum Float where+  toNumber = float2Double+  fromNumber = double2Float++instance JSNum Integer where+  toNumber = fromInteger+  fromNumber = round++mread :: Read a => String -> Maybe a+mread s =+  case reads s of+    [(x, "")] -> x+    _         -> Nothing++instance JSType Int where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Int8 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Int16 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Int32 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType Word where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Word8 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Word16 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Word32 where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType Double where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr+instance JSType Float where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType Integer where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType Bool where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType () where+  toJSString = toJSStr . show+  fromJSString = mread . fromJSStr++instance JSType String where+  toJSString = toJSStr+  fromJSString = Just . fromJSStr++#endif++-- Derived functions++toString :: JSType a => a -> String+toString = fromJSStr . toJSString++fromString :: JSType a => String -> Maybe a+fromString = fromJSString . toJSStr++convert :: (JSNum a, JSNum b) => a -> b+convert = fromNumber . toNumber
+ libraries/haste-lib/src/Haste/LocalStorage.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Basic bindings to HTML5 WebStorage.+module Haste.LocalStorage (setItem, getItem, removeItem) where+import Haste+import Haste.Foreign+import Haste.Serialize+import Haste.JSON+import Control.Applicative++-- | 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);})"++-- | 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);})"++-- | Remove a value from local storage.+removeItem :: String -> IO ()+removeItem = ffi "(function(k) {localStorage.removeItem(k);})"
+ libraries/haste-lib/src/Haste/Parsing.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleInstances #-}+-- | Home-grown parser, just because.+module Haste.Parsing (+    Parse, runParser, char, charP, string, oneOf, possibly, atLeast,+    whitespace, word, Haste.Parsing.words, int, double, positiveDouble,+    suchThat, quotedString, skip, rest, lookahead, anyChar+  ) where+import Control.Applicative+import Control.Monad+import Data.Char++newtype Parse a = Parse {unP :: (String -> Maybe (String, a))}++runParser :: Parse a -> String -> Maybe a+runParser (Parse p) s =+  case p s of+    Just ("", x) -> Just x+    _            -> Nothing++instance Monad Parse where+  return x = Parse $ \s -> Just (s, x)+  Parse m >>= f = Parse $ \s -> do+    (s', x) <- m s+    unP (f x) s'++instance MonadPlus Parse where+  mplus (Parse p1) (Parse p2) = Parse $ \s ->+    case p1 s of+      x@(Just _) -> x+      _          -> p2 s+  mzero = Parse $ const Nothing++instance Functor Parse where+  fmap f (Parse g) = Parse $ fmap (fmap f) . g++instance Applicative Parse where+  pure  = return+  (<*>) = ap++-- | Read one character. Fails if end of stream.+anyChar :: Parse Char+anyChar = Parse $ \s ->+  case s of+    (c:cs) -> Just (cs, c)+    _      -> Nothing++-- | Require a specific character.+char :: Char -> Parse Char+char c = charP (== c)++-- | Parse a character that matches a given predicate.+charP :: (Char -> Bool) -> Parse Char+charP p = Parse $ \s ->+  case s of+    (c:next) | p c -> Just (next, c)+    _              -> Nothing  ++-- | Require a specific string.+string :: String -> Parse String+string str = Parse $ \s ->+  let len        = length str+      (s', next) = splitAt len s+  in if s' == str+       then Just (next, str)+       else Nothing++-- | Apply the first matching parser.+oneOf :: [Parse a] -> Parse a+oneOf = msum++-- | Invoke a parser with the possibility of failure.+possibly :: Parse a -> Parse (Maybe a)+possibly p = oneOf [Just <$> p, return Nothing]++-- | Invoke a parser at least n times.+atLeast :: Int -> Parse a -> Parse [a]+atLeast 0 p = do+  x <- possibly p+  case x of+    Just x' -> do+      xs <- atLeast 0 p+      return (x':xs)+    _ ->+      return []+atLeast n p = do+  x <- p+  xs <- atLeast (n-1) p+  return (x:xs)++-- | Parse zero or more characters of whitespace.+whitespace :: Parse String+whitespace = atLeast 0 $ charP isSpace++-- | Parse a non-empty word. A word is a string of at least one non-whitespace+--   character.+word :: Parse String+word = atLeast 1 $ charP (not . isSpace)++-- | Parse several words, separated by whitespace.+words :: Parse [String]+words = atLeast 0 $ word <* whitespace++-- | Parse an Int.+int :: Parse Int+int = oneOf [read <$> atLeast 1 (charP isDigit),+             char '-' >> (0-) . read <$> atLeast 1 (charP isDigit)]++-- | Parse a floating point number.+double :: Parse Double+double = oneOf [positiveDouble,+                char '-' >> (0-) <$> positiveDouble]++-- | Parse a non-negative floating point number.+positiveDouble :: Parse Double+positiveDouble = do+  first <- atLeast 1 $ charP isDigit+  msecond <- possibly $ char '.' *> atLeast 1 (charP isDigit)+  case msecond of+    Just second -> return $ read $ first ++ "." ++ second+    _           -> return $ read first++-- | Fail on unwanted input.+suchThat :: Parse a -> (a -> Bool) -> Parse a+suchThat p f = do {x <- p ; if f x then return x else mzero}++-- | A string quoted with the given quotation mark. Strings can contain escaped+--   quotation marks; escape characters are stripped from the returned string.+quotedString :: Char -> Parse String+quotedString q = char q *> strContents q <* char q++strContents :: Char -> Parse String+strContents c = do+  s <- atLeast 0 $ charP (\x -> x /= c && x /= '\\')+  c' <- lookahead anyChar+  if c == c'+    then do+      return s+    else do+      skip 1+      c'' <- anyChar+      s' <- strContents c+      return $ s ++ [c''] ++ s'++-- | Read the rest of the input.+rest :: Parse String+rest = Parse $ \s -> Just ("", s)++-- | Run a parser with the current parsing state, but don't consume any input.+lookahead :: Parse a -> Parse a+lookahead p = do+  s' <- Parse $ \s -> Just (s, s)+  x <- p+  Parse $ \_ -> Just (s', x)++-- | Skip n characters from the input.+skip :: Int -> Parse ()+skip n = Parse $ \s -> Just (drop n s, ())
+ libraries/haste-lib/src/Haste/Prim.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, MagicHash, +    TypeSynonymInstances, FlexibleInstances, OverlappingInstances, CPP #-}+module Haste.Prim (JSString, URL, toJSStr, fromJSStr, catJSStr, JSAny,+                   Ptr, toPtr, fromPtr) 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++type URL = String+type JSAny = Ptr Haste.Prim.Any+data Any++-- | Concatenate a series of JSStrings using the specified separator.+catJSStr :: JSString -> [JSString] -> JSString+#ifdef __HASTE__+foreign import ccall jsCat    :: Ptr [JSString] -> JSString -> JSString+catJSStr sep strs = jsCat (toPtr strs) sep+#else+catJSStr sep strs = toJSStr $ intercalate (fromJSStr sep) (map fromJSStr strs)+#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++instance Eq JSString where+  (==) = strEq++instance Ord JSString where+  compare a b = fromPtr (strOrd a b)++instance Show JSString where+  show = fromJSStr++-- | In normal Haskell, we use Storable for data that can be pointed to. When+--   we compile to JS, however, anything can be "pointed" to and nothing needs+--   to be stored.+toPtr :: a -> Ptr a+toPtr = unsafeCoerce . FakePtr++-- | Unwrap a "pointer" to something.+fromPtr :: Ptr a -> a+fromPtr ptr =+  case unsafeCoerce ptr of+    FakePtr val -> val++{-# 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) #-}++toJSStr :: String -> JSString+toJSStr = unsafeCoerce# HP.toJSStr++instance IsString JSString where+  fromString = toJSStr++fromJSStr :: JSString -> String+fromJSStr = unsafeCoerce# HP.fromJSStr++#else++-- | JSStrings are represented as normal strings server-side; should probably+--   be changed to ByteString or Text.+newtype JSString = JSString String++instance IsString JSString where+  fromString = JSString++instance Eq JSString where+  (JSString a) == (JSString b) = a == b++instance Ord JSString where+  (JSString a) `compare` (JSString b) = a `compare` b++instance Show JSString where+  show = fromJSStr++toJSStr :: String -> JSString+toJSStr = JSString++fromJSStr :: JSString -> String+fromJSStr (JSString s) = s++toPtr :: a -> Ptr a+toPtr = error "toPtr used in native code!"++fromPtr :: Ptr a -> a+fromPtr = error "fromPtr used in native code!"++#endif
+ libraries/haste-lib/src/Haste/Random.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ForeignFunctionInterface, CPP #-}+module Haste.Random (Random (..), Seed, next, mkSeed, newSeed) where+import Haste.JSType+import Data.Int+import Data.Word+import Data.List (unfoldr)+import Control.Monad.IO.Class+#ifndef __HASTE__+import System.Random (randomIO)+#endif++#ifdef __HASTE__+foreign import ccall jsRand :: IO Double+#else+jsRand :: IO Double+jsRand = randomIO+#endif++newtype Seed = Seed Int++-- | Create a new seed from an integer.+mkSeed :: Int -> Seed+mkSeed = Seed . convert++-- | Generate a new seed using Javascript's PRNG.+newSeed :: MonadIO m => m Seed+newSeed = liftIO $ do+  x <- jsRand+  s <- jsRand+  let sign = if s > 0.5 then 1 else -1+  return . mkSeed . round $ x*sign*2147483647++-- | Generate the next seed in the sequence.+next :: Seed -> Seed+next (Seed s) =+  Seed s'+  where+    -- This is the same LCG that's used in older glibc versions.+    -- It was chosen because the untruncated product will never be larger than+    -- 2^53 and thus not cause precision problems with JS.+    a  = 69069+    c  = 1+    s' = a*s+c++class Random a where+  -- | Generate a pseudo random number between a lower (inclusive) and higher+  --   (exclusive) bound.+  randomR  :: (a, a) -> Seed -> (a, Seed)+  randomRs :: (a, a) -> Seed -> [a]+  randomRs bounds seed = unfoldr (Just . randomR bounds) seed++instance Random Int where+  randomR (low, high) s@(Seed n) =+    (n' `mod` (high-low) + low, next s)+    where+      -- Use the LCG from MSVC here; less apparent relationship between seed+      -- and output.+      a  = 214013+      c  = 2531011+      n' = a*n+c++instance Random Int32 where+  randomR (l,h) seed =+    case randomR (convert l :: Int, convert h) seed of+      (n, s) -> (convert n, s)++instance Random Word where+  randomR (l,h) seed =+    case randomR (convert l :: Int, convert h) seed of+      (n, s) -> (convert n, s)++instance Random Word32 where+  randomR (l,h) seed =+    case randomR (convert l :: Int, convert h) seed of+      (n, s) -> (convert  n, s)++instance Random Double where+  randomR (low, high) seed =+    (f * (high-low) + low, s)+    where+      (n, s) = randomR (0, 2000000001 :: Int) seed+      f      = convert n / 2000000000
+ libraries/haste-lib/src/Haste/Reactive.hs view
@@ -0,0 +1,4 @@+module Haste.Reactive (module Fursuit, module DOM, module Ajax) where+import FRP.Fursuit as Fursuit+import Haste.Reactive.DOM as DOM+import Haste.Reactive.Ajax as Ajax
+ libraries/haste-lib/src/Haste/Reactive/Ajax.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}+module Haste.Reactive.Ajax (jsonSig, ajaxSig) where+import FRP.Fursuit+import FRP.Fursuit.Async+import Haste.Ajax+import Haste.JSON+import Control.Applicative+import Control.Monad.IO.Class++-- | Create a signal for JSON request. When triggered, the signal causes an+--   XMLHttpRequest to be made to the given URL, with a query string built from+--   the given (key, value) pairs. It notifies its listeners after the request+--   returns.+--   If no data was received, or if the data wasn't JSON, don't notify+--   listeners.+jsonSig :: MonadIO m => Signal URL -> Signal [(Key, Val)] -> m (Signal JSON)+jsonSig requrl kvs = liftIO $ async (ajax <$> requrl <*> kvs)+  where+    ajax url kv p = do+      jsonRequest GET url kv $ \mjson ->+        case mjson of+          Just json -> write p json+          _         -> return ()++-- | Create a signal for a generic AJAX request. It works just like 'jsonSig',+--   but returns its output as plain text rather than JSON.+ajaxSig :: MonadIO m => Signal URL -> Signal [(Key, Val)] -> m (Signal String)+ajaxSig requrl kvs = liftIO $ async (ajax <$> requrl <*> kvs)+  where+    ajax url kv p = do+      textRequest GET url kv $ \mtext -> do+        case mtext of+          Just text -> write p text+          _         -> return ()
+ libraries/haste-lib/src/Haste/Reactive/DOM.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GADTs, FlexibleInstances, MultiParamTypeClasses, +             FlexibleContexts, OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | DOM events and utilities for the Haste reactive library.+module Haste.Reactive.DOM (clicked,valueOf,valueAt,ElemProp,elemProp) where+import FRP.Fursuit+import Haste+import qualified Data.Map as M+import System.IO.Unsafe (unsafePerformIO)+import Data.IORef++{-# NOINLINE eventHandlers #-}+-- | Contains a list of all installed event handlers.+eventHandlers :: JSType a => IORef (M.Map (ElemID, Event IO e) (Signal a))+eventHandlers = unsafePerformIO $ newIORef M.empty++-- | Represents a property of a DOM object.+data ElemProp where+  D :: ElemID -> PropID -> ElemProp++-- | Create a 'DOMObject' from a string describing the object. For example,+--   domObj "myobject.value" corresponds to the value attribute of the object+--   with the ID "myobject".+elemProp :: String -> ElemProp+elemProp str =+  case span (/= '.') str of+    ([], _)     -> error "elemProp: No object ID given!"+    (_, [])     -> error "elemProp: No object attribute given!"+    (obj, attr) -> D obj (tail attr)++unlessExists :: JSType a => ElemID -> Event IO e -> IO (Signal a) -> Signal a+unlessExists eid evt create = new $ do+  handlers <- readIORef eventHandlers+  case M.lookup (eid, evt) handlers of+    Just s -> return s+    _      -> do+      sig <- create+      writeIORef eventHandlers (M.insert (eid, evt) sig handlers)+      return sig+++-- | An event that gets raised whenever the element with the specified ID is+--   clicked.+clicked :: ElemID -> Signal ()+clicked eid = unlessExists eid OnClick clickedIO+  where+    clickedIO = withElem eid $ \e -> do+      (p,s) <- pipe ()+      _ <- setCallback e OnClick (\_ _ -> write p ())+      return s++-- | The value property of the given element, updated whenever an onchange+--   event is raised.+valueOf :: JSType a  => ElemID -> Signal a+valueOf e = e `valueAt` OnChange++-- | The value property of the given element, triggered on a custom event.+valueAt :: (JSType a, Callback e) => ElemID -> Event IO e -> Signal a+valueAt eid evt = filterMapS fromString $ unlessExists eid evt valueAtIO+  where+    valueAtIO = withElem eid $ \e -> do+      str <- getProp e "value"+      (src, sig) <- pipe str+      success <- setCallback e evt $ constCallback $ do+        getProp e "value" >>= write src++      if (not success) +        then error $ "Browser doesn't support sane event handlers!"+        else return sig++-- | Like show, but strips enclosing quotes.+toStr :: Show a => a -> String+toStr x =+  case show x of+    ('"':xs) -> init xs+    xs       -> xs++instance Show a => Sink ElemProp a where+  (D obj attr) << val = withElem obj $ \e -> sink (setProp e attr . toStr) val++-- | Replace the sink element's list of child nodes whenever a new list of+--   nodes comes down the pipe.+instance Sink Elem [Elem] where+  e << val = sink (setChildren e) val++-- | Same as the instance for [Elem].+instance Sink Elem [IO Elem] where+  e << val = sink (\children -> sequence children >>= setChildren e) val++-- | Set the sink element's innerHTML property whenever a new string comes down+--   the pipe.+instance Sink Elem String where+  e << val = sink (setProp e "innerHTML") val
+ libraries/haste-lib/src/Haste/Serialize.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}+-- | JSON serialization and de-serialization for Haste.+module Haste.Serialize (+    Serialize (..), Parser, fromJSON, (.:), (.:?)+  ) where+import GHC.Float+import GHC.Int+import Haste.JSON+import Haste.Prim (JSString, toJSStr, fromJSStr)+import Control.Applicative+import Control.Monad (ap)++class Serialize a where+  toJSON :: a -> JSON++  listToJSON :: [a] -> JSON+  listToJSON = Arr . map toJSON++  parseJSON :: JSON -> Parser a++  parseJSONList :: JSON -> Parser [a]+  parseJSONList (Arr xs) = mapM parseJSON xs+  parseJSONList _        = fail "Tried to deserialie a non-array to a list!"++instance Serialize JSON where+  toJSON = id+  parseJSON = return++instance Serialize Float where+  toJSON = Num . float2Double+  parseJSON (Num x) = return (double2Float x)+  parseJSON _       = fail "Tried to deserialize a non-Number to a Float"++instance Serialize Double where+  toJSON = Num+  parseJSON (Num x) = return x+  parseJSON _       = fail "Tried to deserialize a non-Number to a Double"++instance Serialize Int where+  toJSON = Num . fromIntegral+  parseJSON (Num x) =+    case truncate x of+      x' | fromIntegral x' == x ->+        return x'+      _ ->+        fail "The given Number can't be represented as an Int"+  parseJSON _ =+    fail "Tried to deserialize a non-Number to an Int"++instance Serialize Int8 where+  toJSON = Num . fromIntegral+  parseJSON (Num x) =+    case truncate x of+      x' | x <= 0xff && fromIntegral x' == x ->+        return x'+      _ ->+        fail "The given Number can't be represented as an Int8"+  parseJSON _ =+    fail "Tried to deserialize a non-Number to an Int8"++instance Serialize Int16 where+  toJSON = Num . fromIntegral+  parseJSON (Num x) =+    case truncate x of+      x' | x <= 0xffff && fromIntegral x' == x ->+        return x'+      _ ->+        fail "The given Number can't be represented as an Int16"+  parseJSON _ =+    fail "Tried to deserialize a non-Number to an Int16"++instance Serialize Int32 where+  toJSON = Num . fromIntegral+  parseJSON (Num x) =+    case truncate x of+      x' | x < 0xffffffff && fromIntegral x' == x ->+        return x'+      _ ->+        fail "The given Number can't be represented as an Int32"+  parseJSON _ =+    fail "Tried to deserialize a non-Number to an Int32"++instance Serialize Bool where+  toJSON = Bool+  parseJSON (Bool x) = return x+  parseJSON _        = fail "Tried to deserialize a non-Bool to a Bool"++instance Serialize () where+  toJSON _ = Dict []+  parseJSON _ = return ()++instance Serialize Char where+  toJSON c = Str $ toJSStr [c]+  parseJSON (Str s) =+    case fromJSStr s of+      [c] -> return c+      _   -> fail "Tried to deserialize long string to a Char"+  parseJSON _ =+    fail "Tried to deserialize a non-string to a Char"+  listToJSON = toJSON . toJSStr+  parseJSONList s = fmap fromJSStr (parseJSON s)++instance Serialize JSString where+  toJSON = Str+  parseJSON (Str s) = return s+  parseJSON _ = fail "Tried to deserialize a non-JSString to a JSString"++instance (Serialize a, Serialize b) => Serialize (a, b) where+  toJSON (a, b) = Arr [toJSON a, toJSON b]+  parseJSON (Arr [a, b]) = do+    a' <- parseJSON a+    b' <- parseJSON b+    return (a', b')+  parseJSON _ =+    fail "Tried to deserialize a non-array into a pair!"++instance Serialize a => Serialize (Maybe a) where+  toJSON (Just x)  = Dict [("hasValue", toJSON True), ("value", toJSON x)]+  toJSON (Nothing) = Dict [("hasValue", toJSON False)]+  parseJSON d = do+    hasVal <- d .: "hasValue"+    case hasVal of+      False -> return Nothing+      _     -> Just `fmap` (d .: "value")++instance Serialize a => Serialize [a] where+  toJSON = listToJSON+  parseJSON = parseJSONList++instance (Serialize a, Serialize b) => Serialize (Either a b) where+  toJSON (Right x) = Dict [("success", toJSON True), ("value", toJSON x)]+  toJSON (Left e)  = Dict [("success", toJSON False), ("error", toJSON e)]+  parseJSON d = do+    success <- d .: "success"+    case success of+      False -> Left `fmap` (d .: "error")+      _     -> Right `fmap` (d .: "value")++fromJSON :: Serialize a => JSON -> Either String a+fromJSON = runParser parseJSON++-- | Type for JSON parser.+newtype Parser a = Parser (Either String a)++runParser :: (a -> Parser b) -> a -> Either String b+runParser p x = case p x of Parser y -> y++instance Monad Parser where+  return = Parser . return+  (Parser (Right x)) >>= f = f x+  (Parser (Left e))  >>= _ = Parser (Left e)+  fail = Parser . Left++instance Functor Parser where+  fmap f m = m >>= return . f++instance Applicative Parser where+  (<*>) = ap+  pure  = return++-- | Look up a key in a JSON object.+(.:) :: Serialize a => JSON -> JSString -> Parser a+Dict o .: key =+  case lookup key o of+    Just x -> parseJSON x+    _      -> Parser $ Left "Key not found"+_ .: _ =+  Parser $ Left "Tried to do lookup on non-object!"++(.:?) :: Serialize a => JSON -> JSString -> Parser (Maybe a)+o .:? key =+  case o .: key of+    Parser (Right x) -> return (Just x)+    _                -> return Nothing
+ libraries/haste-lib/src/Haste/WebSockets.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleInstances, EmptyDataDecls, OverloadedStrings #-}+-- | WebSockets API for Haste.+module Haste.WebSockets (+    module Haste.Concurrent,+    WebSocket,+    withWebSocket, withBinaryWebSocket, wsSend, wsSendBlob+  ) where+import Haste+import Haste.Foreign+import Haste.Concurrent hiding (encode, decode)+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 Marshal WebSocket where+  pack = unsafeCoerce+  unpack = unsafeCoerce+instance Marshal WSOnMsg where+  pack = unsafeCoerce+  unpack = unsafeCoerce+instance Marshal WSOnBinMsg where+  pack = unsafeCoerce+  unpack = unsafeCoerce+instance Marshal WSComputation where+  pack = unsafeCoerce+  unpack = unsafeCoerce+instance Marshal WSOnError where+  pack = unsafeCoerce+  unpack = unsafeCoerce++-- | Run a computation with a web socket. The computation will not be executed+--   until a connection to the server has been established.+withWebSocket :: URL+              -- ^ URL to bind the WebSocket to+              -> (WebSocket -> JSString -> CIO ())+              -- ^ Computation to run when new data arrives+              -> CIO a+              -- ^ Computation to run when an error occurs+              -> (WebSocket -> CIO a)+              -- ^ Computation using the WebSocket+              -> 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+    takeMVar result+  where+    cb' = WSOnMsg $ \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.+withBinaryWebSocket :: URL+              -- ^ URL to bind the WebSocket to+              -> (WebSocket -> Blob -> CIO ())+              -- ^ Computation to run when new data arrives+              -> CIO a+              -- ^ Computation to run when an error occurs+              -> (WebSocket -> CIO a)+              -- ^ Computation using the WebSocket+              -> 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+    takeMVar result+  where+    cb' = WSOnBinMsg $ \ws msg -> concurrent $ cb ws msg++new :: URL+    -> WSOnMsg+    -> WSComputation+    -> WSOnError+    -> IO ()+new = ffi "(function(url, cb, f, err) {\+             \var ws = new WebSocket(url);\+             \ws.onmessage = function(e) {A(cb,[ws, [0,e.data],0]);};\+             \ws.onopen = function(e) {A(f,[ws,0]);};\+             \ws.onerror = function(e) {A(err,[0]);};\+             \return ws;\+           \})" ++newBin :: URL+    -> WSOnBinMsg+    -> WSComputation+    -> WSOnError+    -> IO ()+newBin = ffi "(function(url, cb, f, err) {\+                \var ws = new WebSocket(url);\+                \ws.binaryType = 'blob';\+                \ws.onmessage = function(e) {A(cb,[ws,e.data,0]);};\+                \ws.onopen = function(e) {A(f,[ws,0]);};\+                \ws.onerror = function(e) {A(err,[0]);};\+                \return ws;\+              \})" ++-- | Send a string over a WebSocket.+wsSend :: WebSocket -> JSString -> CIO ()+wsSend ws str = liftIO $ sendS ws str++-- | Send a Blob over a WebSocket.+wsSendBlob :: WebSocket -> Blob -> CIO ()+wsSendBlob ws b = liftIO $ sendB ws b++sendS :: WebSocket -> JSString -> IO ()+sendS = ffi "(function(s, msg) {s.send(msg);})"++sendB :: WebSocket -> Blob -> IO ()+sendB = ffi "(function(s, msg) {s.send(msg);})"
src/ArgSpecs.hs view
@@ -24,7 +24,7 @@               updateCfg = \cfg _ -> cfg {targetLibPath = jsmodDir,                                          performLink   = False},               info = "Install all compiled modules into the user's jsmod "-                     ++ "library\nrather than linking them together into a JS"+                     ++ "library rather than linking them together into a JS"                      ++ "blob."},     ArgSpec { optName = "opt-all",               updateCfg = optAllSafe,@@ -32,7 +32,7 @@                      ++ "Equivalent to -O2 --opt-google-closure --opt-whole-program."},     ArgSpec { optName = "opt-all-unsafe",               updateCfg = optAllUnsafe,-              info = "Enable all safe and unsafe optimizations.\n"+              info = "Enable all safe and unsafe optimizations. "                      ++ "Equivalent to --opt-all --opt-unsafe-ints."},     ArgSpec { optName = "opt-google-closure",               updateCfg = updateClosureCfg,@@ -42,7 +42,7 @@     ArgSpec { optName = "opt-sloppy-tce",               updateCfg = useSloppyTCE,               info = "Allow the possibility that some tail recursion may not "-                     ++ "be optimized, to get\nslightly smaller code."},+                     ++ "be optimized, to get slightly smaller code."},     ArgSpec { optName = "opt-unsafe-ints",               updateCfg = unsafeMath,               info = "Enable all unsafe Int math optimizations. Equivalent to "@@ -65,7 +65,7 @@     ArgSpec { optName = "opt-whole-program",               updateCfg = enableWholeProgramOpts,               info = "Perform optimizations over the whole program at link "-                     ++ "time.\nMay significantly increase compilation time."},+                     ++ "time. May significantly increase compilation time."},     ArgSpec { optName = "out=",               updateCfg = \cfg outfile -> cfg {outFile = const $ head outfile},               info = "Write the JS blob to <arg>."},@@ -79,7 +79,10 @@                      ++ "either asap, onload or a custom string "                      ++ "containing the character sequence '%%', which will "                      ++ "be replaced with the program's entry point function. "-                     ++ "The default is onload."},+                     ++ "The default is onload."+                     ++ " Note that '%%' will be replaced by the main function"+                     ++ " itself, not a call to it. Thus, in order to actually"+                     ++ " call the function, one would use '%%()'."},     ArgSpec { optName = "trace-primops",               updateCfg = \cfg _ -> cfg {tracePrimops = True,                                          rtsLibs = debugLib : rtsLibs cfg},
src/Args.hs view
@@ -43,11 +43,22 @@  helpString :: ArgSpec a -> String helpString spec =-  "--" ++ hdr ++ "\n  "-       ++ info spec-       ++ "\n"+  "--" ++ hdr ++ "\n"+       ++ formatHelpMessage (info spec)   where     hdr =       case last $ optName spec of         '=' -> optName spec ++ "<arg>"         _   -> optName spec++-- | Break lines at 80 chars, add two spaces before each.+formatHelpMessage :: String -> String+formatHelpMessage s =+    unlines $ map ("  " ++) $ breakLines 0 [] ws+  where+    ws = words s+    breakLines len ln (w:ws)+      | len+length w >= 78 = unwords (reverse ln) : breakLines 0 [] (w:ws)+      | otherwise          = breakLines (len+1+length w) (w:ln) ws+    breakLines _ ln _ =+      [unwords $ reverse ln]
src/Data/JSTarget/AST.hs view
@@ -77,6 +77,8 @@ data Exp where   Var       :: Var -> Exp   Lit       :: Lit -> Exp+  -- A verbatim JS expression. Must always be non-computing!+  Verbatim  :: String -> Exp   Not       :: Exp -> Exp   BinOp     :: BinOp -> Exp -> Exp -> Exp   Fun       :: Maybe Name -> [Var] -> Stm -> Exp
src/Data/JSTarget/Optimize.hs view
@@ -23,6 +23,7 @@     >>= zapJSStringConversions     >>= optimizeThunks     >>= optimizeArrays+    >>= optUnsafeEval     >>= tailLoopify f     >>= ifReturnToTernary @@ -33,6 +34,7 @@     >>= optimizeArrays     >>= optimizeThunks     >>= optimizeArrays+    >>= zapJSStringConversions  -- | Attempt to turn two case branches into a ternary operator expression. tryTernary :: Var@@ -96,7 +98,8 @@ --   Ignores LhsExp assignments, since we only introduce those when we actually --   care about the assignment side effect. -----   TODO: don't inline thunks into functions!+--   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@@ -114,7 +117,15 @@               case occ of                 -- Inline of any non-lambda value                 Once | mayReorder -> do-                  replaceEx (not <$> isShared) (Var lhs) ex next+                  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@@ -157,9 +168,13 @@ zapJSStringConversions ast =     mapJS (const True) opt return ast   where-    opt (Call _ _ (Var (Foreign "toJSStr"))-       [Call _ _ (Var (Foreign "unCStr")) [x]]) =+    opt (Call _ _ (Var (Foreign "toJSStr")) [+           Call _ _ (Var (Foreign "unCStr")) [x]]) =       return x+    opt (Call _ _ (Var (Foreign "toJSStr")) [+           Call _ _ (Var (Foreign "E")) [+             Call _ _ (Var (Foreign "unCStr")) [x]]]) =+      return x     opt (Call _ _ (Var (Foreign "new T"))          [Fun _ [] (Return x@(Call _ _ (Var (Foreign "unCStr")) [Lit _]))]) =       return x@@ -174,6 +189,8 @@ --     => x --   E(\x ... -> ...) --     => \x ... -> ...+--   thunk(x) where x is non-computing+--     => x optimizeThunks :: JSTrav ast => ast -> TravM ast optimizeThunks ast =     mapJS (const True) optEx return ast@@ -183,10 +200,11 @@       | 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 - -- | Unpack the given expression if it's a thunk. fromThunk :: Exp -> Maybe Stm fromThunk (Call _ Fast (Var (Foreign "new T")) [body]) =@@ -202,6 +220,41 @@   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+    Verbatim _                -> False+    Fun _ _ _                 -> False+    Arr arr                   -> any computingEx arr+    e | Just t <- fromThunk e -> False+      | otherwise             -> True++-- | When possible, optimize ffi "x" into x.+optUnsafeEval :: JSTrav ast => ast -> TravM ast+optUnsafeEval = mapJS (const True) opt return+  where+    opt ex =+      case ex of+        (Call ar c (Var (Internal+          (Name "unsafeEval" (Just (pkg, "Haste.Foreign"))) _))+          [Arr [Lit (LNum 0), Lit (LStr s)]]) | take 9 pkg == "haste-lib" -> do+            return $ Verbatim s+        _ -> do+          return ex   -- | Gather a map of all inlinable symbols; that is, the once that are used
src/Data/JSTarget/Print.hs view
@@ -70,6 +70,8 @@     pp v   pp (Lit l) =     pp l+  pp (Verbatim s) =+    put s   pp (Not ex) =     case neg ex of       Just ex' -> pp ex'
src/Data/JSTarget/Traversal.hs view
@@ -81,6 +81,8 @@                            pure (acc, v)                          l@(Lit _)      -> do                            pure (acc, l)+                         v@(Verbatim _) -> do+                           pure (acc, v)                          Not ex         -> do                            fmap Not <$> mapEx acc ex                          BinOp op a b   -> do@@ -122,6 +124,8 @@                   Var _         -> do                     return acc                   Lit _         -> do+                    return acc+                  Verbatim _    -> do                     return acc                   Not ex        -> do                     foldJS tr f acc ex
src/Haste/Version.hs view
@@ -10,7 +10,7 @@ import Haste.Environment (hasteDir)  hasteVersion :: Version-hasteVersion = Version [0, 2, 11] []+hasteVersion = Version [0, 2, 99] []  ghcVersion :: String ghcVersion = cProjectVersion
src/haste-boot.hs view
@@ -88,12 +88,12 @@ -- | Fetch the Haste base libs. fetchLibs :: FilePath -> Shell () fetchLibs tmpdir = do-    echo "Downloading base libs from ekblad.cc"+    echo "Downloading base libs from GitHub"     file <- downloadFile $ mkUrl hasteVersion     liftIO . unpack tmpdir . read . decompress $ file   where     mkUrl v =-      "http://ekblad.cc/haste-libs/haste-libs-" ++ showVersion v ++ ".tar.bz2"+      "http://valderman.github.io/haste-libs/haste-libs-" ++ showVersion v ++ ".tar.bz2"  -- | Fetch and install the Closure compiler. installClosure :: Shell ()