packages feed

haste-compiler 0.2.99 → 0.3

raw patch · 39 files changed

+731/−901 lines, 39 filesdep ~ghcdep ~shellmate

Dependency ranges changed: ghc, shellmate

Files

haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name:           haste-compiler-Version:        0.2.99+Version:        0.3 License:        BSD3 License-File:   LICENSE Synopsis:       Haskell To ECMAScript compiler@@ -78,7 +78,7 @@         network,         HTTP,         executable-path,-        shellmate >= 0.1.3+        shellmate >= 0.1.5     Default-Language: Haskell98  Executable hastec@@ -105,14 +105,14 @@         process,         random,         system-fileio,-        executable-path+        executable-path,+        shellmate >= 0.1.5     Main-Is:         Main.hs     Other-Modules:         Args         ArgSpecs         Haste-        Haste.Util         Haste.Version         Haste.Environment         Haste.Config@@ -197,15 +197,13 @@         time,         transformers,         executable-path,-        shellmate+        shellmate >= 0.1.5     default-language: Haskell98  Library-    Hs-Source-Dirs: libraries/haste-lib/src, libraries/fursuit/src, src+    Hs-Source-Dirs: libraries/haste-lib/src, src     GHC-Options: -Wall -O2     Exposed-Modules:-        FRP.Fursuit-        FRP.Fursuit.Async         Haste         Haste.App         Haste.App.Concurrent@@ -213,7 +211,6 @@         Haste.Compiler         Haste.JSON         Haste.Ajax-        Haste.Reactive         Haste.DOM         Haste.Prim         Haste.Concurrent@@ -224,10 +221,6 @@         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@@ -235,8 +228,6 @@         Paths_haste_compiler         Haste.Hash         Haste.Random-        Haste.Reactive.DOM-        Haste.Reactive.Ajax         Haste.Concurrent.Monad         Haste.Concurrent.Ajax         Haste.App.Client@@ -261,7 +252,7 @@         websockets >= 0.8,         utf8-string,         -- For Haste.Compiler-        shellmate >= 0.1.3,+        shellmate >= 0.1.5,         data-default,         directory,         executable-path,
lib/rts.js view
@@ -166,6 +166,14 @@     return [0, sign, manHigh, manLow, exp]; } +function isFloatFinite(x) {+    return isFinite(x);+}++function isDoubleFinite(x) {+    return isFinite(x);+}+ function err(str) {     die(toJSStr(str)); }
lib/stdlib.js view
@@ -54,7 +54,8 @@ 	posy = e.clientY + document.body.scrollTop 	    + document.documentElement.scrollTop;     }-    return [posx - e.target.offsetLeft, posy - e.target.offsetTop];+    return [posx - (e.target.offsetLeft || 0),+	    posy - (e.target.offsetTop || 0)]; }  function jsSetCB(elem, evt, cb) {@@ -233,6 +234,8 @@     return arr.join(sep); } +var jsJSONParse = JSON.parse;+ // JSON stringify a string function jsStringify(str) {     return JSON.stringify(str);@@ -266,7 +269,7 @@         break;     case 'object':         if(obj instanceof Array) {-            return [3, arr2lst(obj, 0)];+            return [3, arr2lst_json(obj, 0)];         } else {             // Object type but not array - it's a dictionary.             // The RFC doesn't say anything about the ordering of keys, but@@ -287,11 +290,18 @@     } } +function arr2lst_json(arr, elem) {+    if(elem >= arr.length) {+        return [0];+    }+    return [1, toHS(arr[elem]), new T(function() {return arr2lst_json(arr,elem+1);})]+}+ function arr2lst(arr, elem) {     if(elem >= arr.length) {         return [0];     }-    return [1, toHS(arr[elem]), new T(function() {return arr2lst(arr,elem+1);})]+    return [1, arr[elem], new T(function() {return arr2lst(arr,elem+1);})] }  function lst2arr(xs) {
− libraries/fursuit/src/FRP/Fursuit.hs 
@@ -1,106 +0,0 @@--- | 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 
@@ -1,33 +0,0 @@-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 
@@ -1,33 +0,0 @@-{-# 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 
@@ -1,32 +0,0 @@-{-# 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 
@@ -1,175 +0,0 @@-{-# 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 
@@ -1,26 +0,0 @@-{-# 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
@@ -41,8 +41,8 @@   return (fromJSStr a)  -- | Javascript eval() function.-eval :: MonadIO m => String -> m String-eval js = liftIO $ jsEval (toJSStr js) >>= return . fromJSStr+eval :: MonadIO m => JSString -> m JSString+eval = liftIO . jsEval  -- | Use console.log to write a message. writeLog :: MonadIO m => String -> m ()
libraries/haste-lib/src/Haste/App.hs view
@@ -3,10 +3,10 @@ --   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,+    MonadIO, Remotable, App, Server, Remote, Done,     Sessions, SessionID,-    liftServerIO, forkServerIO, export, runApp,-    (<.>), mkUseful, getSessionID, getActiveSessions, onSessionEnd,+    liftServerIO, forkServerIO, remote, runApp,+    (<.>), getSessionID, getActiveSessions, onSessionEnd,     AppCfg, cfgURL, cfgPort, mkConfig,     Client,     runClient, onServer, liftIO,
libraries/haste-lib/src/Haste/App/Client.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, MultiParamTypeClasses,-             FlexibleInstances #-}+             FlexibleInstances, CPP #-} module Haste.App.Client (     Client, ClientState,     runClient, onServer, liftCIO, get, runClientCIO@@ -16,20 +16,23 @@ import Data.IORef  data ClientState = ClientState {-    csWebSocket  :: WebSocket,+    csSendBlob   :: MVar (Blob -> Client ()),     csNonce      :: IORef Int,     csResultVars :: IORef [(Int, MVar Blob)]   } -initialState :: IORef Int -> IORef [(Int,MVar Blob)] -> WebSocket -> ClientState+initialState :: IORef Int+             -> IORef [(Int,MVar Blob)]+             -> MVar (Blob -> Client ())+             -> ClientState initialState n mv ws =   ClientState {-    csWebSocket  = ws,+    csSendBlob  = ws,     csNonce      = n,     csResultVars = mv   } --- | A client-side computation. See it as XHaste's version of the IO monad.+-- | A client-side computation. See it as Haste.App's version of the IO monad. newtype Client a = Client {     unC :: ClientState -> CIO a   }@@ -61,7 +64,7 @@  instance MonadBlob Client where   getBlobData = liftCIO . getBlobData-  getBlobText = liftCIO . getBlobText+  getBlobText' = liftCIO . getBlobText'   -- | Lift a CIO action into the Client monad.@@ -86,16 +89,19 @@ 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+    let errhandler = error "WebSockets connection died for some reason!"+        openWS blob = do+          wsvar <- get csSendBlob+          liftCIO $ do+            _ <- takeMVar wsvar+            w <- withBinaryWebSocket url (handler mv) errhandler return+            putMVar wsvar (liftCIO . wsSendBlob w)+            wsSendBlob w blob+    ws <- newMVar openWS+    m (initialState n mv ws)   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?+    -- Find the result MVar corresponding to the nonce and write the result to+    -- it, then discard the MVar.     handler rvars _ msg = do       msg' <- getBlobData msg       join . liftIO $ atomicModifyIORef rvars $ \vs ->@@ -124,17 +130,20 @@ 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)+--   computation returns.+onServer :: Binary a => Remote (Server a) -> Client a+#ifdef __HASTE__+onServer (Remote cid args) = __call cid (reverse args)+#else+onServer _ = undefined+#endif  -- | Make a server-side call. __call :: Binary a => CallID -> [Blob] -> Client a __call cid args = do-  ws <- get csWebSocket+  send <- get csSendBlob >>= liftCIO . readMVar   (nonce, mv) <- newResult-  liftCIO . wsSendBlob ws . encode $ ServerCall {+  send . encode $ ServerCall {       scNonce = nonce,       scMethod = cid,       scArgs = args
libraries/haste-lib/src/Haste/App/Concurrent.hs view
@@ -6,27 +6,25 @@ --   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, (!), (<!),+    C.MVar, CC.MBox, CC.Send, CC.Recv, CC.Inbox, CC.Outbox, C.MonadConc (..),+    forkMany, newMVar, newEmptyMVar, takeMVar, putMVar, peekMVar, readMVar,+    CC.spawn, CC.receive, CC.statefully, (CC.!), (CC.<!),     forever   ) where import qualified Haste.Concurrent.Monad as C+import qualified Haste.Concurrent as CC 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+  fork m = do+    cs <- get id+    liftCIO . C.forkIO $ runClientCIO cs m  -- | Spawn several concurrent computations. forkMany :: [Client ()] -> Client ()-forkMany = mapM_ fork+forkMany = mapM_ C.fork  -- | Create a new MVar with the specified contents. newMVar :: a -> Client (C.MVar a)@@ -51,57 +49,8 @@ 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+-- | Read an MVar then put it back. As Javascript is single threaded, this+--   function is atomic. If this ever changes, this function will only be+--   atomic as long as no other thread attempts to write to the MVar.+readMVar :: C.MVar a -> Client a+readMVar = liftCIO . C.readMVar
libraries/haste-lib/src/Haste/App/Monad.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Haste.App startup monad and configuration. module Haste.App.Monad (-    Exportable,-    App, Server, Sessions, SessionID, Useless (..), Export (..), Done (..),+    Remotable,+    App, Server, Sessions, SessionID, Remote (..), Done (..),     AppCfg, def, mkConfig, cfgURL, cfgPort,-    liftServerIO, forkServerIO, export, getAppConfig,-    mkUseful, runApp, (<.>), getSessionID, getActiveSessions, onSessionEnd+    liftServerIO, forkServerIO, remote, getAppConfig,+    runApp, (<.>), getSessionID, getActiveSessions, onSessionEnd   ) where import Control.Applicative import Control.Monad (ap)@@ -30,6 +30,7 @@ import Control.Exception import System.Random import Data.List (foldl')+import Data.String #endif  data AppCfg = AppCfg {@@ -53,15 +54,22 @@ 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]+#ifdef __HASTE__+data Remote a = Remote CallID [Blob]+#else+data Remote a = Remote+#endif  -- | 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)+(<.>) :: Binary a => Remote (a -> b) -> a -> Remote b+#ifdef __HASTE__+(Remote cid args) <.> arg = Remote cid (encode arg:args)+#else+_ <.> _ = Remote+#endif  -- | Application monad; allows for exporting functions, limited liftIO, --   forkIO and launching the client.@@ -89,15 +97,15 @@  -- | Lift an IO action into the Server monad, the result of which can only be --   used server-side.-liftServerIO :: IO a -> App (Useless a)+liftServerIO :: IO a -> App (Server a) #ifdef __HASTE__ {-# RULES "throw away liftServerIO"-          forall x. liftServerIO x = return Useless #-}-liftServerIO _ = return Useless+          forall x. liftServerIO x = return Server #-}+liftServerIO _ = return Server #else liftServerIO m = App $ \cfg _ cid exports -> do   x <- m-  return (Useful x, cid, exports, cfg)+  return (return x, cid, exports, cfg) #endif  -- | Fork off a Server computation not bound an API call.@@ -107,30 +115,30 @@ --   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)+forkServerIO :: Server () -> App (Server ThreadId) #ifdef __HASTE__ {-# RULES "throw away forkServerIO"-          forall x. forkServerIO x = return Useless #-}-forkServerIO _ = return Useless+          forall x. forkServerIO x = return Server #-}+forkServerIO _ = return Server #else forkServerIO (Server m) = App $ \cfg sessions cid exports -> do   tid <- forkIO $ m 0 sessions-  return (Useful tid, cid, exports, cfg)+  return (return tid, cid, exports, cfg) #endif  -- | An exportable function is of the type --   (Serialize a, ..., Serialize result) => a -> ... -> IO result-class Exportable a where+class Remotable a where   serializify :: a -> [Blob] -> (SessionID -> IORef Sessions -> IO Blob) -instance Binary a => Exportable (Server a) where+instance Binary a => Remotable (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+instance (Binary a, Remotable b) => Remotable (a -> b) where #ifdef __HASTE__   serializify _ _ = undefined #else@@ -143,16 +151,16 @@ #endif  -- | Make a function available to the client as an API call.-export :: Exportable a => a -> App (Export a)+remote :: Remotable a => a -> App (Remote 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)+{-# RULES "throw away remote's argument"+          forall x. remote x =+            App $ \c _ cid _ -> return (Remote cid [], cid+1, undefined, c) #-}+remote _ = App $ \c _ cid _ ->+    return (Remote cid [], cid+1, undefined, c) #else-export s = App $ \c _ cid exports ->-    return (Export cid [], cid+1, M.insert cid (serializify s) exports, c)+remote s = App $ \c _ cid exports ->+    return (Remote, cid+1, M.insert cid (serializify s) exports, c) #endif  -- | Register a handler to be run whenever a session terminates.@@ -230,45 +238,64 @@           go #endif --- | Server monad for Haste.App. Allows redeeming Useless values, lifting IO+-- | Server monad for Haste.App. Allows redeeming remote values, lifting IO --   actions, and not much more.+#ifdef __HASTE__+data Server a = Server+#else newtype Server a = Server {unS :: SessionID -> IORef Sessions -> IO a}+#endif  instance Functor Server where+#ifdef __HASTE__+  fmap _ _ = Server+#else   fmap f (Server m) = Server $ \sid ss -> f <$> m sid ss+#endif  instance Applicative Server where   (<*>) = ap   pure  = return  instance Monad Server where+#ifdef __HASTE__+  return _ = Server+  _ >>= _  = Server+#else   return x = Server $ \_ _ -> return x   (Server m) >>= f = Server $ \sid ss -> do     Server m' <- f <$> m sid ss     m' sid ss+#endif  instance MonadIO Server where+#ifdef __HASTE__+  liftIO _ = Server+#else   liftIO m = Server $ \_ _ -> m+#endif  instance MonadBlob Server where #ifndef __HASTE__   getBlobData (Blob bd) = return $ BlobData bd-  getBlobText (Blob bd) = return $ BU.toString $ BS.concat $ BSL.toChunks bd+  getBlobText' (Blob bd) = return $ fromString $ BU.toString $ BS.concat $ BSL.toChunks bd #else-  getBlobData _ = return undefined-  getBlobText _ = return undefined+  getBlobData _ = Server+  getBlobText' _ = Server #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+#ifdef __HASTE__+getSessionID = Server+#else getSessionID = Server $ \sid _ -> return sid+#endif  -- | Return all currently active sessions. getActiveSessions :: Server Sessions+#ifdef __HASTE__+getActiveSessions = Server+#else getActiveSessions = Server $ \_ ss -> readIORef ss+#endif
libraries/haste-lib/src/Haste/Binary.hs view
@@ -5,7 +5,7 @@ module Haste.Binary (     module Haste.Binary.Put,     module Haste.Binary.Get,-    MonadBlob (..), Binary (..),+    MonadBlob (..), Binary (..), getBlobText,     Blob, BlobData,     blobSize, blobDataSize, toByteString, toBlob, strToBlob,     encode, decode@@ -24,9 +24,13 @@ 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+  -- | Interpret a blob as UTF-8 text, as a JSString.+  getBlobText' :: Blob -> m JSString +-- | Interpret a blob as UTF-8 text.+getBlobText :: MonadBlob m => Blob -> m String+getBlobText b = getBlobText' b >>= return . fromJSStr+ instance MonadBlob CIO where   getBlobData b = do       res <- newEmptyMVar@@ -44,10 +48,10 @@       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+  getBlobText' b = do       res <- newEmptyMVar       liftIO $ convertBlob b (toOpaque $ concurrent . putMVar res)-      fromJSStr <$> takeMVar res+      takeMVar res     where       convertBlob :: Blob -> Opaque (JSString -> IO ()) -> IO ()       convertBlob = ffi
libraries/haste-lib/src/Haste/Binary/Types.hs view
@@ -13,7 +13,7 @@  #ifdef __HASTE__ data BlobData = BlobData Int Int Unpacked-newtype Blob = Blob Unpacked deriving Marshal+newtype Blob = Blob Unpacked deriving (Pack, Unpack)  -- | The size, in bytes, of the contents of the given blob. blobSize :: Blob -> Int@@ -46,15 +46,21 @@   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]);})"+newBlob = unsafePerformIO . jsNewBlob++jsNewBlob :: Unpacked -> IO Blob+jsNewBlob =+  ffi "(function(b){try {return new Blob([b]);} catch (e) {return new Blob([b.buffer]);}})" #else  newtype BlobData = BlobData BS.ByteString newtype Blob = Blob BS.ByteString  -- Never used except for type checking-instance Marshal BlobData-instance Marshal Blob+instance Pack BlobData+instance Unpack BlobData+instance Pack Blob+instance Unpack Blob  -- | The size, in bytes, of the contents of the given blob. blobSize :: Blob -> Int
libraries/haste-lib/src/Haste/Concurrent.hs view
@@ -1,8 +1,14 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies,+             EmptyDataDecls #-} -- | Concurrency for Haste. Includes MVars, forking, Ajax and more.-module Haste.Concurrent (module Monad, module Ajax, wait, server) where+module Haste.Concurrent (+    module Monad, module Ajax,+    Recv, Send, Inbox, Outbox, MBox,+    receive, spawn, statefully, (!), (<!),+    wait+  ) where import Haste.Concurrent.Monad as Monad-import Haste.Concurrent.Ajax as Ajax+import Haste.Concurrent.Ajax as Ajax hiding ((!)) import Haste.Callback  -- | Wait for n milliseconds.@@ -12,27 +18,62 @@   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,+instance GenericCallback (CIO ()) CIO where+  type CB (CIO ()) = IO ()+  mkcb toIO m = toIO m+  mkIOfier _ = return concurrent++-- | An MBox is a read/write-only MVar, depending on its first type parameter.+--   Used to communicate with server processes.+newtype MBox t a = MBox (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 :: MonadConc m => Inbox a -> m a+receive (MBox mv) = liftConc $ 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 :: MonadConc m => (Inbox a -> m ()) -> m (Outbox a)+spawn f = do+  p <- liftConc 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.-server :: state -> (state -> evt -> CIO (Maybe state)) -> CIO (MVar evt)-server initialState handler = do-    evtvar <- newEmptyMVar-    forkIO $ loop evtvar initialState-    return evtvar+statefully :: MonadConc m => st -> (st -> evt -> m (Maybe st)) -> m (Outbox evt)+statefully initialState handler = do+    spawn $ loop initialState   where-    loop m st = do-      mresult <- takeMVar m >>= handler st+    loop st p = do+      mresult <- liftConc (receive p) >>= handler st       case mresult of-        Just st' -> loop m st'+        Just st' -> loop st' p         _        -> return () -instance GenericCallback (CIO ()) CIO where-  type CB (CIO ()) = IO ()-  mkcb toIO m = toIO m-  mkIOfier _ = return concurrent+-- | 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.+(!) :: MonadConc m => Outbox a -> a -> m ()+MBox m ! x = liftConc $ forkIO $ 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.+(<!) :: MonadConc m => Outbox a -> m a -> m ()+p <! m = do x <- m ; p ! x
libraries/haste-lib/src/Haste/Concurrent/Monad.hs view
@@ -3,7 +3,7 @@ module Haste.Concurrent.Monad (     MVar, CIO, ToConcurrent (..), MonadConc (..),     forkIO, forkMany, newMVar, newEmptyMVar, takeMVar, putMVar, withMVarIO,-    peekMVar, modifyMVarIO, concurrent, liftIO+    peekMVar, modifyMVarIO, readMVar, concurrent, liftIO   ) where import Control.Monad.IO.Class import Control.Monad.Cont.Class@@ -12,11 +12,13 @@ import Data.IORef  -- | Any monad which supports concurrency.-class MonadConc m where+class Monad m => MonadConc m where   liftConc :: CIO a -> m a+  fork     :: m () -> m ()  instance MonadConc CIO where   liftConc = id+  fork = forkIO  -- | Embed concurrent computations into non-concurrent ones. class ToConcurrent a where@@ -108,6 +110,15 @@   case v of     Full x _ -> return (Just x)     _        -> return Nothing++-- | Read an MVar then put it back. As Javascript is single threaded, this+--   function is atomic. If this ever changes, this function will only be+--   atomic as long as no other thread attempts to write to the MVar.+readMVar :: MVar a -> CIO a+readMVar m = do+  x <- takeMVar m+  putMVar m x+  return x  -- | Write an MVar. Blocks if the MVar is already full. --   Only the first reader in the read queue, if any, is woken.
libraries/haste-lib/src/Haste/DOM.hs view
@@ -7,7 +7,8 @@     addChildBefore, removeChild, clearChildren , getChildBefore,     getLastChild, getChildren, setChildren , getStyle, setStyle,     getStyle', setStyle',-    getFileData, getFileName+    getFileData, getFileName,+    setClass, toggleClass, hasClass   ) where import Haste.Prim import Haste.JSType@@ -17,7 +18,8 @@ import Haste.Binary.Types  newtype Elem = Elem JSAny-instance Marshal Elem+instance Pack Elem+instance Unpack Elem  type PropID = String type ElemID = String@@ -184,8 +186,10 @@       then Just `fmap` getFile e ix       else return Nothing   where+    {-# NOINLINE getFiles #-}     getFiles :: Elem -> IO Int     getFiles = ffi "(function(e){return e.files.length;})"+    {-# NOINLINE getFile #-}     getFile :: Elem -> Int -> IO Blob     getFile = ffi "(function(e,ix){return e.files[ix];})" @@ -200,3 +204,27 @@     separator '/'  = True     separator '\\' = True     separator _    = False++-- | Add or remove a class from an element's class list.+setClass :: MonadIO m => Elem -> String -> Bool -> m ()+setClass e c x = liftIO $ setc e c x+  where+    {-# NOINLINE setc #-}+    setc :: Elem -> String -> Bool -> IO ()+    setc = ffi "(function(e,c,x){x?e.classList.add(c):e.classList.remove(c);})"++-- | Toggle the existence of a class within an elements class list.+toggleClass :: MonadIO m => Elem -> String -> m ()+toggleClass e c = liftIO $ toggc e c+  where+    {-# NOINLINE toggc #-}+    toggc :: Elem -> String -> IO ()+    toggc = ffi "(function(e,c) {e.classList.toggle(c);})"++-- | Does the given element have a particular class?+hasClass :: MonadIO m => Elem -> String -> m Bool+hasClass e c = liftIO $ getc e c+  where+    {-# NOINLINE getc #-}+    getc :: Elem -> String -> IO Bool+    getc = ffi "(function(e,c) {return e.classList.contains(c);})"
libraries/haste-lib/src/Haste/Foreign.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances,              FlexibleInstances, TypeFamilies, OverlappingInstances, CPP,-             OverloadedStrings #-}+             OverloadedStrings, UndecidableInstances #-} -- | 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+    FFI, Pack (..), Unpack (..), Marshal,+    Unpacked, Opaque,+    ffi, export, toOpaque, fromOpaque   ) where import Haste.Prim import Haste.JSType@@ -43,59 +45,188 @@  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+class Pack a where   pack :: Unpacked -> a   pack = unsafePack +class Unpack a where   unpack :: a -> Unpacked   unpack = unsafeUnpack -instance Marshal Float-instance Marshal Double-instance Marshal JSString where+-- | Class for marshallable types. Pack takes an opaque JS value and turns it+--   into the type's proper Haste representation, and unpack is its inverse.+--   The default instances make an effort to prevent wrongly typed values+--   through, but you could probably break them with enough creativity.+class (Pack a, Unpack a) => Marshal a+instance (Pack a, Unpack a) => Marshal a++instance Pack Float+instance Pack Double+instance Pack JSAny+instance Pack JSString where   pack = jsString . unsafePack-instance Marshal Int where+instance Pack Int where   pack x = convert (unsafePack x :: Double)-instance Marshal Int8 where+instance Pack Int8 where   pack x = convert (unsafePack x :: Double)-instance Marshal Int16 where+instance Pack Int16 where   pack x = convert (unsafePack x :: Double)-instance Marshal Int32 where+instance Pack Int32 where   pack x = convert (unsafePack x :: Double)-instance Marshal Word where+instance Pack Word where   pack x = convert (unsafePack x :: Double)-instance Marshal Word8 where+instance Pack Word8 where   pack x = convert (unsafePack x :: Double)-instance Marshal Word16 where+instance Pack Word16 where   pack x = convert (unsafePack x :: Double)-instance Marshal Word32 where+instance Pack Word32 where   pack x = convert (unsafePack x :: Double)-instance Marshal () where+instance Pack () where   pack _   = ()-  unpack _ = unpack (0 :: Double)-instance Marshal String where+instance Pack String where   pack = fromJSStr . pack-  unpack = unpack . toJSStr-instance Marshal Unpacked where+instance Pack Unpacked where   pack = id-  unpack = id-instance Marshal (Opaque a) where+instance Pack (Opaque a) where   pack = Opaque+instance Pack Bool where+  pack x = if pack x > (0 :: Double) then True else False++-- | Lists are marshalled into arrays.+instance Pack a => Pack [a] where+  pack arr = map pack . fromOpaque $ arr2lst arr 0++-- | Maybe is simply a nullable type. Nothing is equivalent to null, and any+--   non-null value is equivalent to x in Just x.+instance Pack a => Pack (Maybe a) where+  pack x = if isNull x then Nothing else Just (pack x)++-- | Tuples are marshalled into arrays.+instance (Pack a, Pack b) => Pack (a, b) where+  pack x = case pack x of [a, b] -> (pack a, pack b)++instance (Pack a, Pack b, Pack c) => Pack (a, b, c) where+  pack x = case pack x of [a, b, c] -> (pack a, pack b, pack c)++instance (Pack a, Pack b, Pack c, Pack d) =>+         Pack (a, b, c, d) where+  pack x = case pack x of [a, b, c, d] -> (pack a, pack b, pack c, pack d)++instance (Pack a, Pack b, Pack c, Pack d, Pack e) =>+         Pack (a, b, c, d, e) where+  pack x = case pack x of [a,b,c,d,e] -> (pack a, pack b, pack c, pack d, pack e)++instance (Pack a, Pack b, Pack c, Pack d, Pack e,+          Pack f) => Pack (a, b, c, d, e, f) where+  pack x = case pack x of+    [a, b, c, d, e, f] -> (pack a, pack b, pack c, pack d, pack e, pack f)++instance (Pack a, Pack b, Pack c, Pack d, Pack e,+          Pack f, Pack g) => Pack (a, b, c, d, e, f, g) where+  pack x = case pack x of+    [a, b, c, d, e, f, g] -> (pack a,pack b,pack c,pack d,pack e,pack f,pack g)++instance (Pack a, Pack b, Pack c, Pack d, Pack e,+          Pack f, Pack g, Pack h) =>+         Pack (a, b, c, d, e, f, g, h) where+  pack x = case pack x of+    [a, b, c, d, e, f, g, h] -> (pack a, pack b, pack c, pack d, pack e,+                                 pack f, pack g, pack h)++instance (Pack a, Pack b, Pack c, Pack d, Pack e,+          Pack f, Pack g, Pack h, Pack i) =>+         Pack (a, b, c, d, e, f, g, h, i) where+  pack x = case pack x of+    [a, b, c, d, e, f, g, h, i] -> (pack a, pack b, pack c, pack d, pack e,+                                    pack f, pack g, pack h, pack i)++instance (Pack a, Pack b, Pack c, Pack d, Pack e,+          Pack f, Pack g, Pack h, Pack i, Pack j) =>+         Pack (a, b, c, d, e, f, g, h, i, j) where+  pack x = case pack x of+    [a, b, c, d, e, f, g, h, i, j] -> (pack a, pack b, pack c, pack d, pack e,+                                       pack f, pack g, pack h, pack i, pack j)++instance Unpack Float+instance Unpack Double+instance Unpack JSAny+instance Unpack JSString+instance Unpack Int+instance Unpack Int8+instance Unpack Int16+instance Unpack Int32+instance Unpack Word+instance Unpack Word8+instance Unpack Word16+instance Unpack Word32+instance Unpack () where+  unpack _ = unpack (0 :: Double)+instance Unpack String where+  unpack = unpack . toJSStr+instance Unpack Unpacked where+  unpack = id+instance Unpack (Opaque a) where   unpack (Opaque x) = x-instance Marshal Bool where+instance Unpack 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+instance Unpack a => Unpack [a] where   unpack = lst2arr . toOpaque . map unpack-  pack arr = map pack . fromOpaque $ arr2lst arr 0 +-- | Maybe is simply a nullable type. Nothing is equivalent to null, and any+--   non-null value is equivalent to x in Just x.+instance Unpack a => Unpack (Maybe a) where+  unpack Nothing  = jsNull+  unpack (Just x) = unpack x++-- | Tuples are marshalled into arrays.+instance (Unpack a, Unpack b) => Unpack (a, b) where+  unpack (a, b) = unpack [unpack a, unpack b]++instance (Unpack a, Unpack b, Unpack c) => Unpack (a, b, c) where+  unpack (a, b, c) = unpack [unpack a, unpack b, unpack c]++instance (Unpack a, Unpack b, Unpack c, Unpack d) =>+         Unpack (a, b, c, d) where+  unpack (a, b, c, d) = unpack [unpack a, unpack b, unpack c, unpack d]++instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e) =>+         Unpack (a, b, c, d, e) where+  unpack (a, b, c, d, e) = unpack [unpack a,unpack b,unpack c,unpack d,unpack e]++instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,+          Unpack f) => Unpack (a, b, c, d, e, f) where+  unpack (a, b, c, d, e, f) =+    unpack [unpack a, unpack b, unpack c, unpack d, unpack e, unpack f]++instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,+          Unpack f, Unpack g) => Unpack (a, b, c, d, e, f, g) where+  unpack (a, b, c, d, e, f, g) =+    unpack [unpack a,unpack b,unpack c,unpack d,unpack e,unpack f,unpack g]++instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,+          Unpack f, Unpack g, Unpack h) =>+         Unpack (a, b, c, d, e, f, g, h) where+  unpack (a, b, c, d, e, f, g, h) =+    unpack [unpack a, unpack b, unpack c, unpack d, unpack e,+            unpack f, unpack g, unpack h]++instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,+          Unpack f, Unpack g, Unpack h, Unpack i) =>+         Unpack (a, b, c, d, e, f, g, h, i) where+  unpack (a, b, c, d, e, f, g, h, i) =+    unpack [unpack a, unpack b, unpack c, unpack d, unpack e,+            unpack f, unpack g, unpack h, unpack i]++instance (Unpack a, Unpack b, Unpack c, Unpack d, Unpack e,+          Unpack f, Unpack g, Unpack h, Unpack i, Unpack j) =>+         Unpack (a, b, c, d, e, f, g, h, i, j) where+  unpack (a, b, c, d, e, f, g, h, i, j) =+    unpack [unpack a, unpack b, unpack c, unpack d, unpack e,+            unpack f, unpack g, unpack h, unpack i, unpack j]+ {-# RULES "unpack array/Unpacked" forall x. unpack x = lst2arr (toOpaque x) #-} {-# RULES "pack array/Unpacked" forall x. pack x = fromOpaque (arr2lst x 0) #-} @@ -103,14 +234,7 @@ 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)+arr2lst arr ix = unsafePerformIO $ ffi "arr2lst" arr ix  jsNull, jsTrue, jsFalse :: Unpacked jsTrue = unsafePerformIO $ ffi "true"
libraries/haste-lib/src/Haste/Graphics/Canvas.hs view
@@ -12,7 +12,7 @@   -- Working with bitmaps   bitmapElem,   -- Rendering pictures, extracting data from a canvas-  render, buffer, toDataURL,+  render, renderOnTop, buffer, toDataURL,   -- Working with colors and opacity   setStrokeColor, setFillColor, color, opacity,   -- Matrix operations@@ -210,6 +210,12 @@ render (Canvas ctx el) (Picture p) = liftIO $ do   jsResetCanvas el   p ctx++-- | Draw a picture onto a canvas without first clearing it.+{-# SPECIALISE renderOnTop :: Canvas -> Picture a -> IO a #-}+{-# SPECIALISE renderOnTop :: Canvas -> Picture a -> CIO a #-}+renderOnTop :: MonadIO m => Canvas -> Picture a -> m a+renderOnTop (Canvas ctx el) (Picture p) = liftIO $ p ctx  -- | Generate a data URL from the contents of a canvas. toDataURL :: MonadIO m => Canvas -> m URL
libraries/haste-lib/src/Haste/Hash.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts, GADTs, OverloadedStrings #-} -- | Hash manipulation and callbacks.-module Haste.Hash (onHashChange, setHash, getHash) where+module Haste.Hash (+    onHashChange, onHashChange', setHash, getHash, setHash', getHash'+  ) where import Haste.Foreign import Control.Monad.IO.Class import Haste.Callback@@ -9,8 +11,9 @@  newtype HashCallback = HashCallback (JSString -> JSString -> IO ()) -instance Marshal HashCallback where+instance Pack HashCallback where   pack = unsafeCoerce+instance Unpack HashCallback where   unpack = unsafeCoerce  -- | Register a callback to be run whenever the URL hash changes.@@ -19,21 +22,52 @@               => (String -> String -> m ())               -> m () onHashChange f = do+    firsthash <- getHash'     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]);\-             \    };\-             \})"+    liftIO $ jsOnHashChange firsthash (HashCallback f') +-- | JSString version of @onHashChange@.+onHashChange' :: (MonadIO m, GenericCallback (m ()) m, CB (m ()) ~ IO ())+              => (JSString -> JSString -> m ())+              -> m ()+onHashChange' f = do+    firsthash <- getHash'+    f' <- toCallback f+    liftIO $ jsOnHashChange firsthash (HashCallback f')++{-# NOINLINE jsOnHashChange #-}+jsOnHashChange :: JSString -> HashCallback -> IO ()+jsOnHashChange =+  ffi "(function(firsthash,cb){\+          \window.__old_hash = firsthash;\+          \window.onhashchange = function(e){\+            \var oldhash = window.__old_hash;\+            \var newhash = window.location.hash.split('#')[1] || '';\+            \window.__old_hash = newhash;\+            \A(cb, [[0,oldhash],[0,newhash],0]);\+          \};\+       \})"+ -- | Set the hash part of the current URL. setHash :: MonadIO m => String -> m ()-setHash = liftIO . ffi "(function(h) {location.hash = '#'+h;})"+setHash = liftIO . jsSetHash . toJSStr +-- | Set the hash part of the current URL - JSString version.+setHash' :: MonadIO m => JSString -> m ()+setHash' = liftIO . jsSetHash++{-# NOINLINE jsSetHash #-}+jsSetHash :: JSString -> IO ()+jsSetHash = 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);})"+getHash = liftIO $ fromJSStr `fmap` jsGetHash++-- | Read the hash part of the currunt URL - JSString version.+getHash' :: MonadIO m => m JSString+getHash' = liftIO jsGetHash++{-# NOINLINE jsGetHash #-}+jsGetHash :: IO JSString+jsGetHash = ffi "(function() {return location.hash.substring(1);})"
libraries/haste-lib/src/Haste/JSON.hs view
@@ -5,7 +5,7 @@ --   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+module Haste.JSON (JSON (..), encodeJSON, decodeJSON, toObject, (!), (~>)) where import Haste.Prim import Data.String as S #ifndef __HASTE__@@ -14,6 +14,17 @@ import Data.Char (ord) import Numeric (showHex) #endif++-- | Create a Javascript object from a JSON object. Only makes sense in a+--   browser context, obviously.+toObject :: JSON -> JSAny+#ifdef __HASTE__+toObject = jsJSONParse . encodeJSON+foreign import ccall jsJSONParse :: JSString -> JSAny+#else+toObject j = error $ "Call to toObject in non-browser: " ++ show j+#endif+  -- Remember to update jsParseJSON if this data type changes! data JSON
libraries/haste-lib/src/Haste/Random.hs view
@@ -1,46 +1,63 @@-{-# LANGUAGE ForeignFunctionInterface, CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, OverloadedStrings #-} 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)+import System.IO.Unsafe+#ifdef __HASTE__+import Haste.Foreign+#else+import qualified System.Random as SR #endif  #ifdef __HASTE__-foreign import ccall jsRand :: IO Double++newtype Seed = Seed Unpacked deriving (Pack, Unpack)++{-# NOINLINE nxt #-}+nxt :: Seed -> IO Seed+nxt = ffi "(function(s){return md51(s.join(','));})"++{-# NOINLINE getN #-}+getN :: Seed -> IO Int+getN = ffi "(function(s){return s[0];})"++{-# NOINLINE toSeed #-}+toSeed :: Int -> IO Seed+toSeed = ffi "(function(n){return md51(n.toString());})"++{-# NOINLINE createSeed #-}+createSeed :: IO Seed+createSeed = ffi "(function(){return md51(jsRand().toString());})" #else-jsRand :: IO Double-jsRand = randomIO-#endif+newtype Seed = Seed (Int, SR.StdGen) -newtype Seed = Seed Int+nxt :: Seed -> IO Seed+nxt (Seed (_, g)) = return . Seed $ SR.next g +getN :: Seed -> IO Int+getN (Seed (n, _)) = return n++toSeed :: Int -> IO Seed+toSeed = return . Seed . SR.next . SR.mkStdGen++createSeed :: IO Seed+createSeed = SR.newStdGen >>= return . Seed . SR.next+#endif+ -- | Create a new seed from an integer. mkSeed :: Int -> Seed-mkSeed = Seed . convert+mkSeed = unsafePerformIO . toSeed  -- | 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+newSeed = liftIO createSeed  -- | 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+next = unsafePerformIO . nxt  class Random a where   -- | Generate a pseudo random number between a lower (inclusive) and higher@@ -50,14 +67,12 @@   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+  randomR (low, high) s+    | low <= high =+      let n = unsafePerformIO $ getN s+      in  (n `mod` (high-low+1) + low, next s)+    | otherwise =+      randomR (high, low) s  instance Random Int32 where   randomR (l,h) seed =
− libraries/haste-lib/src/Haste/Reactive.hs 
@@ -1,4 +0,0 @@-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 
@@ -1,34 +0,0 @@-{-# 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 
@@ -1,93 +0,0 @@-{-# 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/WebSockets.hs view
@@ -15,22 +15,28 @@ newtype WSOnBinMsg = WSOnBinMsg (WebSocket -> Blob -> IO ()) newtype WSComputation = WSComputation (WebSocket -> IO ()) newtype WSOnError = WSOnError (IO ())- data WebSocket-instance Marshal WebSocket where++instance Pack WebSocket where   pack = unsafeCoerce-  unpack = unsafeCoerce-instance Marshal WSOnMsg where+instance Pack WSOnMsg where   pack = unsafeCoerce-  unpack = unsafeCoerce-instance Marshal WSOnBinMsg where+instance Pack WSOnBinMsg where   pack = unsafeCoerce-  unpack = unsafeCoerce-instance Marshal WSComputation where+instance Pack WSComputation where   pack = unsafeCoerce-  unpack = unsafeCoerce-instance Marshal WSOnError where+instance Pack WSOnError where   pack = unsafeCoerce++instance Unpack WebSocket where+  unpack = unsafeCoerce+instance Unpack WSOnMsg where+  unpack = unsafeCoerce+instance Unpack WSOnBinMsg where+  unpack = unsafeCoerce+instance Unpack WSComputation where+  unpack = unsafeCoerce+instance Unpack WSOnError where   unpack = unsafeCoerce  -- | Run a computation with a web socket. The computation will not be executed
src/ArgSpecs.hs view
@@ -39,6 +39,11 @@               info = "Run the Google Closure compiler on the output. "                    ++ "Use --opt-google-closure=foo.jar to hint that foo.jar "                    ++ "is the Closure compiler."},+    ArgSpec { optName = "opt-google-closure-flag=",+              updateCfg = updateClosureFlags,+              info = "Add an extra flag for the Google Closure compiler to take. "+                   ++ "Use --opt-google-closure-flag='--language_in=ECMASCRIPT5_STRICT', "+                   ++ "to optimize programs to strict mode"},     ArgSpec { optName = "opt-sloppy-tce",               updateCfg = useSloppyTCE,               info = "Allow the possibility that some tail recursion may not "@@ -67,8 +72,11 @@               info = "Perform optimizations over the whole program at link "                      ++ "time. May significantly increase compilation time."},     ArgSpec { optName = "out=",-              updateCfg = \cfg outfile -> cfg {outFile = const $ head outfile},-              info = "Write the JS blob to <arg>."},+              updateCfg = \cfg outfile -> cfg {outFile = \_ _ -> head outfile},+              info = "Write compiler output to <arg>."},+    ArgSpec { optName = "output-html",+              updateCfg = \cfg _ -> cfg {outputHTML = True},+              info = "Produce a skeleton HTML file containing the program."},     ArgSpec { optName = "separate-namespace",               updateCfg = \cfg _ -> cfg {wrapProg = True},               info = "Wrap the program in its own namespace? "@@ -130,6 +138,11 @@   cfg {useGoogleClosure = Just arg} updateClosureCfg cfg _ =   cfg {useGoogleClosure = Just closureCompiler}++-- | Add flags for Google Closure to use+updateClosureFlags :: Config -> [String] -> Config+updateClosureFlags cfg args = cfg {+  useGoogleClosureFlags = useGoogleClosureFlags cfg ++ args}  -- | Enable optimizations over the entire program. enableWholeProgramOpts :: Config -> [String] -> Config
src/Data/JSTarget/Constructors.hs view
@@ -95,12 +95,7 @@  -- | Create a thunk. thunk :: AST Stm -> AST Exp-thunk stm@(AST s js) =-  case s of-    (Return ex) | not $ evaluates ex ->-      AST ex js-    _ ->-      callForeign "new T" [Fun Nothing [] <$> stm]+thunk stm = callForeign "new T" [Fun Nothing [] <$> stm]  -- | Unpack the given expression if it's a thunk without internal bindings. fromThunk :: AST Exp -> Maybe (AST Exp)
src/Data/JSTarget/Optimize.hs view
@@ -35,6 +35,7 @@     >>= optimizeThunks     >>= optimizeArrays     >>= zapJSStringConversions+    >>= optUnsafeEval  -- | Attempt to turn two case branches into a ternary operator expression. tryTernary :: Var@@ -138,7 +139,6 @@           return keep     inl _ stm = return stm - -- | Turn if(foo) {return bar;} else {return baz;} into return foo ? bar : baz. ifReturnToTernary :: JSTrav ast => ast -> TravM ast ifReturnToTernary ast = do@@ -181,7 +181,6 @@     opt x =       return x - -- | Optimize thunks in the following ways: --   A(thunk(return f), xs) --     => A(f, xs)@@ -189,8 +188,11 @@ --     => x --   E(\x ... -> ...) --     => \x ... -> ...---   thunk(x) where x is non-computing+--   thunk(x) where x is non-computing and non-recursive --     => x+--+--   TODO: figure out efficient way to only perform the 4th optimization when x+--         is not recursive. optimizeThunks :: JSTrav ast => ast -> TravM ast optimizeThunks ast =     mapJS (const True) optEx return ast@@ -200,8 +202,8 @@       | 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 | Just ex' <- fromThunkEx ex, not (computingEx ex') =+--      return ex'     optEx ex =       return ex @@ -251,8 +253,11 @@       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+          (Arr [Lit (LNum 0), Lit (LStr s)] : args))+          | take 9 pkg == "haste-lib" -> do+            case args of+              [] -> return $ Verbatim s+              _  -> return $ Call (ar-1) c (Verbatim s) args         _ -> do           return ex @@ -423,5 +428,6 @@     contains (Arr xs) var         = any (`contains` var) xs     contains (AssignEx l r) var   = l `contains` var || r `contains` var     contains (IfEx c t e) var     = any (`contains` var) [c,t,e]+    contains (Verbatim _) _       = False tailLoopify _ fun = do   return fun
src/Haste/CodeGen.hs view
@@ -9,6 +9,9 @@ import Data.Char import Data.List (partition, foldl') import Data.Maybe (isJust)+#if __GLASGOW_HASKELL__ >= 707+import qualified Data.ByteString.Char8 as B+#endif import qualified Data.Set as S import qualified Data.Map as M -- STG/GHC stuff@@ -38,7 +41,6 @@ import Haste.Errors import Haste.PrimOps import Haste.Builtins-import Haste.Util (showOutputable)  generate :: Config          -> Fingerprint@@ -56,7 +58,7 @@     }   where     theMod = genAST cfg modname binds-    +     insFun m (_, AST (Assign (NewVar _ (Internal v _)) body _) jumps) =       M.insert v (AST body jumps) m     insFun m _ =@@ -139,7 +141,7 @@   cfg <- getCfg   let theOp = case op of         StgPrimOp op' ->-          maybeTrace cfg (showOutputable op') args' <$> genOp cfg op' args'+          maybeTrace cfg (showOutputable cfg op') args' <$> genOp cfg op' args'         StgPrimCallOp (PrimCall f _) ->           Right $ maybeTrace cfg fs args' $ callForeign fs args'           where fs = unpackFS f@@ -194,7 +196,7 @@ --   a recursive binding; this is because it's quite a lot easier to keep track --   of which functions depend on each other if every genBind call results in a --   single function being generated.---   Use `genBindRec` to generate code for local potentially recursive bindings +--   Use `genBindRec` to generate code for local potentially recursive bindings --   as their dependencies get merged into their parent's anyway. genBind :: Bool -> Maybe Int -> StgBinding -> JSGen Config () genBind onTopLevel funsInRecGroup (StgNonRec v rhs) = do@@ -245,7 +247,7 @@ genArgVarsPair :: [(Var.Var, a)] -> JSGen Config ([J.Var], [a]) genArgVarsPair vps = do     vs' <- mapM genVar vs-    return (vs', xs) +    return (vs', xs)   where     (vs, xs) = unzip $ filter (hasRepresentation . fst) vps @@ -300,7 +302,7 @@ splitAlts alts =     case partition isDefault alts of       ([defAlt], otherAlts) -> (defAlt, otherAlts)-      ([], otherAlts)       -> (last otherAlts, init otherAlts) +      ([], otherAlts)       -> (last otherAlts, init otherAlts)       _                     -> error "More than one default alt in case!"   where     isDefault (DEFAULT, _, _, _) = True@@ -326,7 +328,9 @@  -- | Generate a result variable for the given scrutinee variable. genResultVar :: Var.Var -> JSGen Config J.Var-genResultVar v = (\mn -> toJSVar mn v (Just "#result")) <$> getModName+genResultVar v = do+  cfg <- getCfg+  (\mn -> toJSVar cfg mn v (Just "#result")) <$> getModName  -- | Generate a new variable and add a dependency on it to the function --   currently being generated.@@ -336,7 +340,8 @@     Just v' -> return v'     _       -> do       mymod <- getModName-      v' <- return $ toJSVar mymod v Nothing+      cfg <- getCfg+      v' <- return $ toJSVar cfg mymod v Nothing       dependOn v'       return v' genVar _ = do@@ -354,8 +359,8 @@ foreignName _ =   error "Dynamic foreign calls not supported!" -toJSVar :: String -> Var.Var -> Maybe String -> J.Var-toJSVar thisMod v msuffix =+toJSVar :: Config -> String -> Var.Var -> Maybe String -> J.Var+toJSVar c thisMod v msuffix =   case idDetails v of     FCallId fc -> foreignVar (foreignName fc)     _@@ -377,7 +382,7 @@     myMod =       maybe thisMod (moduleNameString . moduleName) (nameModule_maybe vname)     myPkg =-      maybe "main" (showOutputable . modulePackageId) (nameModule_maybe vname)+      maybe "main" (showOutputable c . modulePackageId) (nameModule_maybe vname)     extern = occNameString $ nameOccName vname     unique = show $ nameUnique vname @@ -456,7 +461,11 @@ genLit :: L.Literal -> JSGen Config (AST Exp) genLit l = do   case l of+#if __GLASGOW_HASKELL__ >= 707+    MachStr s           -> return . lit $ B.unpack s+#else     MachStr s           -> return . lit $ unpackFS s+#endif     MachInt n       | n > 2147483647 ||         n < -2147483648 -> do warn Verbose (constFail "Int" n)@@ -501,7 +510,7 @@  -- | Does this data constructor create an enumeration type? isEnumerationDataCon :: DataCon -> Bool-isEnumerationDataCon = isEnumerationTyCon . dataConTyCon    +isEnumerationDataCon = isEnumerationTyCon . dataConTyCon  -- | Returns True if the given Var is an unboxed tuple with a single element --   after any represenationless elements are discarded.
src/Haste/Config.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, Rank2Types #-} module Haste.Config (   Config (..), AppStart, defConfig, stdJSLibs, startCustom, fastMultiply,   safeMultiply, debugLib) where@@ -8,6 +8,7 @@ import Blaze.ByteString.Builder.Char.Utf8 import Data.Monoid import Haste.Environment+import Outputable (Outputable)  type AppStart = Builder -> Builder @@ -75,7 +76,7 @@     ppOpts :: PPOpts,     -- | A function that takes the name of the a target as its input and     --   outputs the name of the file its JS blob should be written to.-    outFile :: String -> String,+    outFile :: Config -> String -> String,     -- | Link the program?     performLink :: Bool,     -- | A function to call on each Int arithmetic primop.@@ -93,8 +94,16 @@     tracePrimops :: Bool,     -- | Run the entire thing through Google Closure when done?     useGoogleClosure :: Maybe FilePath,+    -- | Extra flags for Google Closure to take?+    useGoogleClosureFlags :: [String],     -- | Any external Javascript to link into the JS bundle.-    jsExternals :: [FilePath]+    jsExternals :: [FilePath],+    -- | Produce a skeleton HTML file containing the program rather than a+    --   JS file.+    outputHTML :: Bool,+    -- | GHC DynFlags used for STG generation.+    --   Currently only used for printing StgSyn values.+    showOutputable :: forall a. Outputable a => a -> String   }  -- | Default compiler configuration.@@ -106,7 +115,10 @@     appStart         = startOnLoadComplete,     wrapProg         = False,     ppOpts           = def,-    outFile          = flip replaceExtension "js",+    outFile          = \cfg f -> let ext = if outputHTML cfg+                                             then "html"+                                             else "js"+                                 in replaceExtension f ext,     performLink      = True,     wrapIntMath      = strictly32Bits,     multiplyIntOp    = safeMultiply,@@ -115,5 +127,8 @@     sloppyTCE        = False,     tracePrimops     = False,     useGoogleClosure = Nothing,-    jsExternals      = []+    useGoogleClosureFlags = [],+    jsExternals      = [],+    outputHTML       = False,+    showOutputable   = const "No showOutputable defined in config!"   }
src/Haste/Linker.hs view
@@ -29,7 +29,7 @@      rtslibs <- mapM readFile $ rtsLibs cfg   extlibs <- mapM readFile $ jsExternals cfg-  B.writeFile (outFile cfg target)+  B.writeFile (outFile cfg cfg target)     $ toLazyByteString     $ assembleProg (wrapProg cfg) extlibs rtslibs progText callMain launchApp   where
src/Haste/PrimOps.hs view
@@ -4,7 +4,6 @@ import PrimOp import Data.JSTarget import Haste.Config-import Haste.Util  -- | Dummy State# RealWorld value for where one is needed. defState :: AST Exp@@ -315,7 +314,7 @@     -- noDuplicate is only relevant in a threaded environment.     NoDuplicateOp  -> Right $ defState     CatchOp        -> callF "jsCatch"-    x              -> Left $ "Unsupported PrimOp: " ++ showOutputable x+    x              -> Left $ "Unsupported PrimOp: " ++ showOutputable cfg x   where     (arr:ix:_) = xs
− src/Haste/Util.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE CPP #-}--- | Misc. utility functions.-module Haste.Util where-import DynFlags-import Outputable--#if __GLASGOW_HASKELL__ >= 706-showOutputable :: Outputable a => a -> String-showOutputable = showPpr tracingDynFlags-#else-showOutputable :: Outputable a => a -> String-showOutputable = showPpr-#endif
src/Haste/Version.hs view
@@ -10,7 +10,7 @@ import Haste.Environment (hasteDir)  hasteVersion :: Version-hasteVersion = Version [0, 2, 99] []+hasteVersion = Version [0, 3] []  ghcVersion :: String ghcVersion = cProjectVersion
src/Main.hs view
@@ -15,7 +15,6 @@ import System.Environment (getArgs) import Control.Monad (when) import Haste-import Haste.Util (showOutputable) import Haste.Environment import Haste.Version import Args@@ -30,6 +29,7 @@ import Data.List import Data.String import qualified Data.ByteString.Char8 as B+import qualified Control.Shell as Sh  logStr :: String -> IO () logStr = hPutStrLn stderr@@ -119,12 +119,12 @@   case argRes of     -- We got --help as an argument - display help and exit.     Left help -> putStrLn help-    +     -- We got a config and a set of arguments for GHC; let's compile!     Right (cfg, ghcargs) -> do       -- Parse static flags, but ignore profiling.       (ghcargs', _) <- parseStaticFlags [noLoc a | a <- ghcargs, a /= "-prof"]-      +       runGhc (Just libdir) $ handleSourceError (const $ liftIO exitFailure) $ do         -- Handle dynamic GHC flags. Make sure __HASTE__ is #defined.         let args = "-D__HASTE__" : map unLoc ghcargs'@@ -142,33 +142,62 @@           _ <- load LoadAllTargets           depanal [] False         mapM_ (compile cfg dynflags') deps-        +         -- Link everything together into a .js file.         when (performLink cfg) $ liftIO $ do           flip mapM_ files' $ \file -> do-            logStr $ "Linking " ++ outFile cfg file+            let outfile = outFile cfg cfg file+            logStr $ "Linking " ++ outfile #if __GLASGOW_HASKELL__ >= 706             let pkgid = showPpr dynflags $ thisPackage dynflags' #else             let pkgid = showPpr $ thisPackage dynflags' #endif             link cfg pkgid file-            case useGoogleClosure cfg of -              Just clopath -> closurize clopath $ outFile cfg file+            case useGoogleClosure cfg of+              Just clopath -> closurize clopath+                                        outfile+                                        (useGoogleClosureFlags cfg)               _            -> return ()+            when (outputHTML cfg) $ do+              res <- Sh.shell $ Sh.withCustomTempFile "." $ \tmp h -> do+                prog <- Sh.file outfile+                Sh.hPutStrLn h (htmlSkeleton outfile prog)+                Sh.liftIO $ hClose h+                Sh.mv tmp outfile+              case res of+                Right () -> return ()+                Left err -> error $ "Couldn't output HTML file: " ++ err +-- | Produce an HTML skeleton with an embedded JS program.+htmlSkeleton :: FilePath -> String -> String+htmlSkeleton filename prog = concat [+  "<!DOCTYPE HTML>",+  "<html><head>",+  "<title>", filename , "</title>",+  "<meta charset=\"UTF-8\">",+  "<script type=\"text/javascript\">", prog, "</script>",+  "</head><body></body></html>"]+ -- | Do everything required to get a list of STG bindings out of a module. prepare :: (GhcMonad m) => DynFlags -> ModSummary -> m ([StgBinding], ModuleName) prepare dynflags theMod = do   env <- getSession   let name = moduleName $ ms_mod theMod+#if __GLASGOW_HASKELL__ >= 707+      mod  = ms_mod theMod+#endif   pgm <- parseModule theMod     >>= typecheckModule     >>= desugarModule     >>= liftIO . hscSimplify env . coreModule     >>= liftIO . tidyProgram env     >>= prepPgm env . fst+#if __GLASGOW_HASKELL__ >= 707+    >>= liftIO . coreToStg dynflags mod+#else     >>= liftIO . coreToStg dynflags+#endif   return (pgm, name)   where     prepPgm env tidy = liftIO $ do@@ -181,14 +210,16 @@   -- | Run Google Closure on a file.-closurize :: FilePath -> FilePath -> IO ()-closurize cloPath file = do+closurize :: FilePath -> FilePath -> [String] -> IO ()+closurize cloPath file arguments = do   logStr $ "Running the Google Closure compiler on " ++ file ++ "..."   let cloFile = file `addExtension` ".clo"   cloOut <- openFile cloFile WriteMode   build <- runProcess "java"-             ["-jar", cloPath, "--compilation_level", "ADVANCED_OPTIMIZATIONS",+             (["-jar", cloPath,+              "--compilation_level", "ADVANCED_OPTIMIZATIONS",               "--jscomp_off", "globalThis", file]+              ++ arguments)              Nothing              Nothing              Nothing@@ -225,10 +256,12 @@           (pgm, name) <- prepare dynflags modSummary #if __GLASGOW_HASKELL__ >= 706           let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary+              cfg' = cfg {showOutputable = showPpr dynflags} #else           let pkgid = showPpr $ modulePackageId $ ms_mod modSummary+              cfg' = cfg {showOutputable = showPpr} #endif-              theCode = generate cfg fp pkgid name pgm+              theCode = generate cfg' fp pkgid name pgm           liftIO $ logStr $ "Compiling " ++ myName ++ " into " ++ targetpath           liftIO $ writeModule targetpath theCode   where
src/haste-boot.hs view
@@ -18,6 +18,7 @@ import Control.Shell import Data.Char (isDigit) import Control.Monad.IO.Class (liftIO)+import Args  downloadFile :: String -> Shell BS.ByteString downloadFile f = do@@ -37,40 +38,67 @@     getLibs      :: Bool,     getClosure   :: Bool,     useLocalLibs :: Bool,-    tracePrimops :: Bool+    tracePrimops :: Bool,+    forceBoot    :: Bool   } +defCfg :: Cfg+defCfg = Cfg {+    getLibs = True,+    getClosure = True,+    useLocalLibs = False,+    tracePrimops = False,+    forceBoot = False+  }++specs :: [ArgSpec Cfg]+specs = [+    ArgSpec { optName = "force",+              updateCfg = \cfg _ -> cfg {forceBoot = True},+              info = "Re-boot Haste even if already properly booted."},+    ArgSpec { optName = "local",+              updateCfg = \cfg _ -> cfg {useLocalLibs = True},+              info = "Use libraries from source repository rather than " +++                     "downloading a matching set from the Internet. " +++                     "This is nearly always necessary when installing " +++                     "Haste from Git rather than from Hackage. " +++                     "When using --local, your current working directory " +++                     "must be the root of the Haste source tree."},+    ArgSpec { optName = "no-closure",+              updateCfg = \cfg _ -> cfg {getClosure = False},+              info = "Don't download Closure compiler. You won't be able " +++                     "to use --opt-google-closure, unless you manually " +++                     "give it the path to compiler.jar."},+    ArgSpec { optName = "no-libs",+              updateCfg = \cfg _ -> cfg {getLibs = False},+              info = "Don't install any libraries. This is probably not " +++                     "what you want."},+    ArgSpec { optName = "trace-primops",+              updateCfg = \cfg _ -> cfg {tracePrimops = True},+              info = "Build standard libs for tracing of primitive " +++                     "operations. Only use if you're debugging the code " +++                     "generator."}+  ]+ main :: IO () main = do   args <- getArgs-  -- Always get base and closure when forced unless explicitly asked not to;-  -- if not forced, get base and closure when necessary, unless asked not to.-  let forceBoot = elem "--force" args-      libs      = if elem "--no-libs" args-                     then False-                     else forceBoot || needsReboot-      closure   = if elem "--no-closure" args-                     then False-                     else forceBoot || needsReboot-      local     = elem "--local" args-      trace     = elem "--trace-primops" args-      cfg = Cfg {-          getLibs      = libs,-          getClosure   = closure,-          useLocalLibs = local,-          tracePrimops = trace-        }--  when (needsReboot || forceBoot) $ do-    res <- shell $ if local-                     then bootHaste cfg "."-                     else withTempDirectory "haste" $ bootHaste cfg-    case res of-      Right _  -> return ()-      Left err -> putStrLn err >> exitFailure+  case handleArgs defCfg specs args of+    Right (cfg, _) -> do+      when (needsReboot || forceBoot cfg) $ do+        res <- shell $ if useLocalLibs cfg+                         then bootHaste cfg "."+                         else withTempDirectory "haste" $ bootHaste cfg+        case res of+          Right _  -> return ()+          Left err -> putStrLn err >> exitFailure+    Left halp -> do+      putStrLn halp  bootHaste :: Cfg -> FilePath -> Shell () bootHaste cfg tmpdir = inDirectory tmpdir $ do+  removeBootFile <- isFile bootFile+  when removeBootFile $ rm bootFile   when (getLibs cfg) $ do     when (not $ useLocalLibs cfg) $ do       fetchLibs tmpdir@@ -124,7 +152,7 @@     inDirectory "libraries" $ do       -- Install ghc-prim       inDirectory "ghc-prim" $ do-        hasteInst ["configure"]+        hasteInst ["configure", "--solver", "topdown"]         hasteInst $ ["build", "--install-jsmods"] ++ ghcOpts         run_ hasteInstHisBinary ["ghc-prim-0.3.0.0", "dist" </> "build"] ""         run_ hastePkgBinary ["update", "packageconfig"] ""@@ -132,7 +160,7 @@       -- Install integer-gmp; double install shouldn't be needed anymore.       run_ hasteCopyPkgBinary ["Cabal"] ""       inDirectory "integer-gmp" $ do-        hasteInst ("install" : ghcOpts)+        hasteInst ("install" : "--solver" : "topdown" : ghcOpts)              -- Install base       inDirectory "base" $ do@@ -142,15 +170,16 @@           . filter (not . null)           . filter (and . zipWith (==) "version")           . lines-        hasteInst ["configure"]+        hasteInst ["configure", "--solver", "topdown"]         hasteInst $ ["build", "--install-jsmods"] ++ ghcOpts         let base = "base-" ++ basever             pkgdb = "--package-db=dist" </> "package.conf.inplace"         run_ hasteInstHisBinary [base, "dist" </> "build"] ""         run_ hasteCopyPkgBinary [base, pkgdb] ""+        cpDir "include" hasteDir       -      -- Install array, fursuit and haste-lib-      forM_ ["array", "fursuit", "haste-lib"] $ \pkg -> do+      -- Install array and haste-lib+      forM_ ["array", "haste-lib"] $ \pkg -> do         inDirectory pkg $ hasteInst ("install" : ghcOpts)   where     ghcOpts = concat [