diff --git a/haste-compiler.cabal b/haste-compiler.cabal --- a/haste-compiler.cabal +++ b/haste-compiler.cabal @@ -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, diff --git a/lib/rts.js b/lib/rts.js --- a/lib/rts.js +++ b/lib/rts.js @@ -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)); } diff --git a/lib/stdlib.js b/lib/stdlib.js --- a/lib/stdlib.js +++ b/lib/stdlib.js @@ -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) { diff --git a/libraries/fursuit/src/FRP/Fursuit.hs b/libraries/fursuit/src/FRP/Fursuit.hs deleted file mode 100644 --- a/libraries/fursuit/src/FRP/Fursuit.hs +++ /dev/null @@ -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) diff --git a/libraries/fursuit/src/FRP/Fursuit/Async.hs b/libraries/fursuit/src/FRP/Fursuit/Async.hs deleted file mode 100644 --- a/libraries/fursuit/src/FRP/Fursuit/Async.hs +++ /dev/null @@ -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 diff --git a/libraries/fursuit/src/FRP/Fursuit/Locking.hs b/libraries/fursuit/src/FRP/Fursuit/Locking.hs deleted file mode 100644 --- a/libraries/fursuit/src/FRP/Fursuit/Locking.hs +++ /dev/null @@ -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 diff --git a/libraries/fursuit/src/FRP/Fursuit/Pipe.hs b/libraries/fursuit/src/FRP/Fursuit/Pipe.hs deleted file mode 100644 --- a/libraries/fursuit/src/FRP/Fursuit/Pipe.hs +++ /dev/null @@ -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 diff --git a/libraries/fursuit/src/FRP/Fursuit/Signal.hs b/libraries/fursuit/src/FRP/Fursuit/Signal.hs deleted file mode 100644 --- a/libraries/fursuit/src/FRP/Fursuit/Signal.hs +++ /dev/null @@ -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 diff --git a/libraries/fursuit/src/FRP/Fursuit/Sink.hs b/libraries/fursuit/src/FRP/Fursuit/Sink.hs deleted file mode 100644 --- a/libraries/fursuit/src/FRP/Fursuit/Sink.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste.hs b/libraries/haste-lib/src/Haste.hs --- a/libraries/haste-lib/src/Haste.hs +++ b/libraries/haste-lib/src/Haste.hs @@ -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 () diff --git a/libraries/haste-lib/src/Haste/App.hs b/libraries/haste-lib/src/Haste/App.hs --- a/libraries/haste-lib/src/Haste/App.hs +++ b/libraries/haste-lib/src/Haste/App.hs @@ -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, diff --git a/libraries/haste-lib/src/Haste/App/Client.hs b/libraries/haste-lib/src/Haste/App/Client.hs --- a/libraries/haste-lib/src/Haste/App/Client.hs +++ b/libraries/haste-lib/src/Haste/App/Client.hs @@ -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 diff --git a/libraries/haste-lib/src/Haste/App/Concurrent.hs b/libraries/haste-lib/src/Haste/App/Concurrent.hs --- a/libraries/haste-lib/src/Haste/App/Concurrent.hs +++ b/libraries/haste-lib/src/Haste/App/Concurrent.hs @@ -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, (!), ( 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. -( Client a -> Client () -p Client a +readMVar = liftCIO . C.readMVar diff --git a/libraries/haste-lib/src/Haste/App/Monad.hs b/libraries/haste-lib/src/Haste/App/Monad.hs --- a/libraries/haste-lib/src/Haste/App/Monad.hs +++ b/libraries/haste-lib/src/Haste/App/Monad.hs @@ -1,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 diff --git a/libraries/haste-lib/src/Haste/Binary.hs b/libraries/haste-lib/src/Haste/Binary.hs --- a/libraries/haste-lib/src/Haste/Binary.hs +++ b/libraries/haste-lib/src/Haste/Binary.hs @@ -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 diff --git a/libraries/haste-lib/src/Haste/Binary/Types.hs b/libraries/haste-lib/src/Haste/Binary/Types.hs --- a/libraries/haste-lib/src/Haste/Binary/Types.hs +++ b/libraries/haste-lib/src/Haste/Binary/Types.hs @@ -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 diff --git a/libraries/haste-lib/src/Haste/Concurrent.hs b/libraries/haste-lib/src/Haste/Concurrent.hs --- a/libraries/haste-lib/src/Haste/Concurrent.hs +++ b/libraries/haste-lib/src/Haste/Concurrent.hs @@ -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, (!), ( 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. +( Outbox a -> m a -> m () +p 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. diff --git a/libraries/haste-lib/src/Haste/DOM.hs b/libraries/haste-lib/src/Haste/DOM.hs --- a/libraries/haste-lib/src/Haste/DOM.hs +++ b/libraries/haste-lib/src/Haste/DOM.hs @@ -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);})" diff --git a/libraries/haste-lib/src/Haste/Foreign.hs b/libraries/haste-lib/src/Haste/Foreign.hs --- a/libraries/haste-lib/src/Haste/Foreign.hs +++ b/libraries/haste-lib/src/Haste/Foreign.hs @@ -1,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" diff --git a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs --- a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs +++ b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs @@ -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 diff --git a/libraries/haste-lib/src/Haste/Hash.hs b/libraries/haste-lib/src/Haste/Hash.hs --- a/libraries/haste-lib/src/Haste/Hash.hs +++ b/libraries/haste-lib/src/Haste/Hash.hs @@ -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);})" diff --git a/libraries/haste-lib/src/Haste/JSON.hs b/libraries/haste-lib/src/Haste/JSON.hs --- a/libraries/haste-lib/src/Haste/JSON.hs +++ b/libraries/haste-lib/src/Haste/JSON.hs @@ -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 diff --git a/libraries/haste-lib/src/Haste/Random.hs b/libraries/haste-lib/src/Haste/Random.hs --- a/libraries/haste-lib/src/Haste/Random.hs +++ b/libraries/haste-lib/src/Haste/Random.hs @@ -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 = diff --git a/libraries/haste-lib/src/Haste/Reactive.hs b/libraries/haste-lib/src/Haste/Reactive.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Reactive.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Reactive/Ajax.hs b/libraries/haste-lib/src/Haste/Reactive/Ajax.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Reactive/Ajax.hs +++ /dev/null @@ -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 () diff --git a/libraries/haste-lib/src/Haste/Reactive/DOM.hs b/libraries/haste-lib/src/Haste/Reactive/DOM.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Reactive/DOM.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/WebSockets.hs b/libraries/haste-lib/src/Haste/WebSockets.hs --- a/libraries/haste-lib/src/Haste/WebSockets.hs +++ b/libraries/haste-lib/src/Haste/WebSockets.hs @@ -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 diff --git a/src/ArgSpecs.hs b/src/ArgSpecs.hs --- a/src/ArgSpecs.hs +++ b/src/ArgSpecs.hs @@ -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 ."}, + updateCfg = \cfg outfile -> cfg {outFile = \_ _ -> head outfile}, + info = "Write compiler output to ."}, + 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 diff --git a/src/Data/JSTarget/Constructors.hs b/src/Data/JSTarget/Constructors.hs --- a/src/Data/JSTarget/Constructors.hs +++ b/src/Data/JSTarget/Constructors.hs @@ -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) diff --git a/src/Data/JSTarget/Optimize.hs b/src/Data/JSTarget/Optimize.hs --- a/src/Data/JSTarget/Optimize.hs +++ b/src/Data/JSTarget/Optimize.hs @@ -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 diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs --- a/src/Haste/CodeGen.hs +++ b/src/Haste/CodeGen.hs @@ -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. diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs --- a/src/Haste/Config.hs +++ b/src/Haste/Config.hs @@ -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!" } diff --git a/src/Haste/Linker.hs b/src/Haste/Linker.hs --- a/src/Haste/Linker.hs +++ b/src/Haste/Linker.hs @@ -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 diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs --- a/src/Haste/PrimOps.hs +++ b/src/Haste/PrimOps.hs @@ -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 diff --git a/src/Haste/Util.hs b/src/Haste/Util.hs deleted file mode 100644 --- a/src/Haste/Util.hs +++ /dev/null @@ -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 diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -10,7 +10,7 @@ import Haste.Environment (hasteDir) hasteVersion :: Version -hasteVersion = Version [0, 2, 99] [] +hasteVersion = Version [0, 3] [] ghcVersion :: String ghcVersion = cProjectVersion diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 [ + "", + "", + "", filename , "", + "", + "", + ""] + -- | 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 diff --git a/src/haste-boot.hs b/src/haste-boot.hs --- a/src/haste-boot.hs +++ b/src/haste-boot.hs @@ -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 [