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