diff --git a/Network/JMacroRPC/Base.hs b/Network/JMacroRPC/Base.hs --- a/Network/JMacroRPC/Base.hs +++ b/Network/JMacroRPC/Base.hs @@ -168,8 +168,7 @@ _ -> return $ errToVal Nothing (-32700) "not passed an object" where - toInt (I i) = fromIntegral i - toInt (D d) = round d + toInt sci = round sci jresToVal :: Int -> JResult -> Value jresToVal ident jres = diff --git a/Network/JMacroRPC/Panels.hs b/Network/JMacroRPC/Panels.hs --- a/Network/JMacroRPC/Panels.hs +++ b/Network/JMacroRPC/Panels.hs @@ -33,7 +33,7 @@ > selPanel <> > (onEvent evt $ > withSample selSignal $ \ selChoice -> -> select (show selChoice, selChoice) +> select (show selChoice, selChoice) > [(show $ selChoice + 1, selChoice + 1)] $ \ _evt selSignal2 selPanel2 -> > button "click me" $ \ buttonEvt buttonPanel -> > onEvent buttonEvt $ @@ -50,16 +50,16 @@ module Network.JMacroRPC.Panels ( -- * Base Types JS, Hask, PanelPath, - Event, Signal, Sink, + Event(..), Signal(..), Sink(..), -- * The PState Monad Transformer - PanelState, PState, newIdent, descended, + PanelState(..), PState, newIdent, descended, -- * Page Slices and Panels - PageSlice(..), Panel(..), + PageSlice(..), Panel(..), UpdateList, -- * Base Type Combinators - pureSig, + pureSig, zipSinks, contramapJs, @@ -74,7 +74,7 @@ -- * Interacting with signals, sinks, and events withSample, - sampleSigJs, + sampleSigJs, onEvent, tellSink, bindSigSink, @@ -118,6 +118,7 @@ import qualified Data.Text.Lazy as T import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.ByteString.Char8 as B + import qualified Text.Blaze.Html.Renderer.Pretty as P import qualified Text.Blaze.Html.Renderer.Text as T import Data.List.Split @@ -137,7 +138,7 @@ -- | Conceptually, an Event is something that can trigger an update. -- We can join two events (which gives us "or" semantics), and we can --- trigger on an event. That's it. +-- trigger on an event. That's it. -- In reality, an event is composed of the panelpaths to it's sources. data Event = Event [PanelPath] @@ -155,6 +156,7 @@ OneSig :: FromJSON a => PanelPath -> Signal typ a MultiSig :: Signal typ1 a -> Signal typ2 b -> ((a,b) -> c) -> Signal Hask c +-- TODO have a writer carry dependencies seperately, then make the real instance a free sucker. also carry pure vs. not. -- TODO, IO Signals? instance Functor (Signal Hask) where @@ -174,11 +176,11 @@ -- | Sinks likewise are tagged as JS, Hask, or parametric. A sink of type JS can be written to purely on the client side, with no round trip. A sink of type Hask is a contravariant functor. -data Sink typ m a where +data Sink typ m a where ServerSink :: (a -> PState m [JStat]) -> Sink Hask m a PureSink :: ToJExpr a => JExpr -> Sink typ m a -liftSink :: Monad m => Sink typ m a -> Sink Hask m a +liftSink :: Monad m => Sink typ m a -> Sink Hask m a liftSink (PureSink js) = ServerSink $ \x -> return [ [jmacro|`(js)` `(x)`|] ] liftSink (ServerSink f) = ServerSink f @@ -255,7 +257,7 @@ modify (\s -> s {ps_path = incrPath i}) return i --- | And we can get an identifier out before descending into a "local" +-- | And we can get an identifier out before descending into a "local" -- environment whose identifiers don't affect the main supply. Hence if -- a local environment alters its pattern of consumption, identifiers -- in the outer environment will remain stable. @@ -385,18 +387,19 @@ ) (return []) +--TODO pure js version when both are explicitly js. Make it nontransparent. -- | Given an event, a signal, and a sink, on each firing of the event, feed the sink the current sampled value of the signal. If the Signal and Sink are both in JS, this can happen entirely on the client side. bindSigSink :: (Monad m, Functor m, FromJSON a, ToJSON a) => Event -> Signal typ1 a -> Sink typ2 m a -> Panel m bindSigSink (Event depList) (PureSig a) (PureSink js) = Panel draw (newIdent >> return []) where draw = newIdent >>= \i -> return $ PS mempty (map (\eid -> [jmacro|clientEventDepends `(printPath i)` `(printPath eid)` (\ -> `(js)` `(toJSON a)`);|]) depList) - -bindSigSink (Event depList) (OneSig sid) (PureSink js) = Panel draw (newIdent >> return []) + +bindSigSink (Event depList) (OneSig sid) (PureSink js) = Panel draw (newIdent >> return []) where draw = newIdent >>= \i -> return $ PS mempty (map (\eid -> [jmacro|clientEventDepends `(printPath i)` `(printPath eid)` (\ -> `(js)` $("#"+`(sid)`).val());|]) depList) bindSigSink ev sig sink = onEvent ev . withSample sig $ \i -> tellSink sink i --- | This is a general purpose function for constructing Panels that provide signals and events, and optionally sinks. It takes a function from an identifier path to an intial value of a signal, optional sinks into the signal, and a panel "controlling" the signal. From this it yields a continuation function from the event and signal associated wih the panel, the optional sinks, and the signal "control" panel to a new panel to the new panel iself. +-- | This is a general purpose function for constructing Panels that provide signals and events, and optionally sinks. It takes a function from an identifier path to an intial value of a signal, optional sinks into the signal, and a panel "controlling" the signal. From this it yields a continuation function from the event and signal associated wih the panel, the optional sinks, and the signal "control" panel to a new panel to the new panel iself. -- Usage of this function is best understood by viewing the source of inputs built using it. buildInput :: (FromJSON a, ToJSON a, Monad m, Functor m) => (PanelPath -> (a, sinks, Panel m)) -- ^ given a path, construct a so-located panel with an intial value and possibly some Sinks. @@ -464,8 +467,8 @@ -- @bindEventIO e act = onEvent e $ Panel (return mempty) (lift act >> return mempty)@ bindEventIO :: (Monad m, Functor m) => Event -> m () -> Panel m bindEventIO e act = onEvent e $ Panel (return mempty) (lift act >> return mempty) - + -- | a wrapper around select that immediately samples from the yielded signal. @selectInput defOpt opts k = select defOpt opts $ \e sig p -> withSample sig $ \i -> k e i p@ selectInput :: (Monad m, Functor m, FromJSON a, ToJSON a) => (String, a) -> [(String,a)] -> (Event -> a -> Panel m -> Panel m) -> Panel m @@ -508,7 +511,7 @@ inDiv :: (Monad m, Functor m) => [Panel m] -> Panel m inDiv = onHtml H.div . mconcat --- | Put some text into a p element. +-- | Put some text into a p element. -- @para = plainHTML . H.p . fromString@ para :: (Monad m, Functor m) => String -> Panel m para = plainHTML . H.p . fromString @@ -586,7 +589,7 @@ // Map IDPath (Map IDPath (() -> IO ())) var !eventToClientDepsMap = {}; - + // IDPath -> Set IDPath fun subsetIDMapFromPfx pfx mp { var pfl = pfx.length; @@ -671,7 +674,7 @@ delete listener listenerToParentDataMap; } } - + // -- each client listener goes away for(var evt in eventToClientDepsMap) { if(evt.slice(0,pfl) == uid) { @@ -774,16 +777,17 @@ panelToPageGen :: forall m resp. (Monad m, Functor m, ToJsonRPC (m (Either String UpdateList)) m) => ([JsonRPC m ()] -> m resp) -- ^ A function which serves stateless JsonRPCs. -> (T.Text -> m resp) -- ^ A function which renders Text to a server response. + -> Maybe String -- ^ An optional url to find JQuery -> String -- ^ A page title. - -> Panel m -- ^ The panel to server + -> Panel m -- ^ The panel to server -> (m resp, m resp) -- ^ Two page handlers -- one for handling updates (POSTs), and the second for rendering the initial page (GETs). -panelToPageGen serveRpcs returnResponse title p = (updateHandler, drawHandler) +panelToPageGen serveRpcs returnResponse jqLoc title p = (updateHandler, drawHandler) where drawHandler = do dp <- runPanelDraw M.empty S.empty $ p returnResponse $ T.renderHtml $ H.html $ do H.head $ do H5.title (fromString title) - H.script ! H.src (toValue "https://ajax.googleapis.com/ajax/libs/jquery/1.8.1/jquery.min.js") $ mempty + H.script ! H.src (toValue $ fromMaybe "https://ajax.googleapis.com/ajax/libs/jquery/1.8.1/jquery.min.js" jqLoc) $ mempty H.script . fromString . show . renderJs $ invokeRPCLib `mappend` rpcDecls `mappend` panelPrelude H.script . fromString . show . renderJs . wrapJQuery . jsP $ dp H.body . htmlP $ dp @@ -804,9 +808,11 @@ show . renderJs . mconcat . jsP $ ps) updateRPC :: JsonRPC m () - updateRPC = toJsonRPC "updateEvent" $ \envMap depDataMap eventSet -> updateFun envMap depDataMap eventSet + updateRPC = toJsonRPC "updateEvent" $ \envMap depDataMap eventSet -> updateFun (M.map textToBS envMap) (M.map (M.map textToBS) depDataMap) eventSet + textToBS = BS.fromChunks . (:[]) . T.encodeUtf8 + -- TODO more interesting control with inputs, like a dial or something. @@ -832,9 +838,9 @@ bindSigSink e (pureSig "0") storeInp <> bindSigSink e (pureSig "0") displayInp <> bindSigSink e (pureSig "") cmdstoreInp - equalButton = button "=" $ \ e b -> b <> onEvent e + equalButton = button "=" $ \ e b -> b <> onEvent e (withSample cmdstoresig $ \cmdstoreval -> - withSample displaysig $ \dispval -> + withSample displaysig $ \dispval -> withSample storesig $ \storeval -> let execOp op = tellSink displayInp (show $ (read storeval :: Int) `op` (read dispval :: Int)) in case cmdstoreval of diff --git a/jmacro-rpc.cabal b/jmacro-rpc.cabal --- a/jmacro-rpc.cabal +++ b/jmacro-rpc.cabal @@ -1,15 +1,15 @@ Name: jmacro-rpc -Version: 0.2 -Homepage: http://patch-tag.com/r/gershomb/jmacro-rpc +Version: 0.3 +Homepage: http://hub.darcs.net/gershomb/jmacro License: BSD3 License-file: LICENSE Author: Gershom Bazerman Maintainer: gershomb@gmail.com -Category: Network +Category: Network, Web Build-type: Simple Cabal-version: >=1.6 -Synopsis: JSON-RPC clients and servers using JMacro, and evented client-server FRP. +Synopsis: JSON-RPC clients and servers using JMacro, and evented client-server Reactive Programming. Description: Base jmacro-rpc package. Provides server-independent functions. @@ -17,10 +17,10 @@ Exposed-modules: Network.JMacroRPC.Base, Network.JMacroRPC.Panels - Build-depends: base >= 4, base < 7, jmacro > 0.6, text > 0.11, containers >= 0.4, bytestring >= 0.9.1, vector >= 0.8, attoparsec > 0.10, aeson >= 0.6, mtl > 2, unordered-containers > 0.1.4, split >= 0.2, blaze-html >= 0.4, contravariant >= 0.1 + Build-depends: base >= 4, base < 7, jmacro > 0.6, text > 0.11, containers >= 0.4, bytestring >= 0.9.1, vector >= 0.8, attoparsec > 0.10, aeson >= 0.6, mtl > 2, unordered-containers > 0.1.4, split >= 0.2, blaze-html >= 0.4, contravariant >= 0.1, scientific > 0.3 ghc-options: -Wall source-repository head type: darcs - location: http://patch-tag.com/r/gershomb/jmacro-rpc + location: http://hub.darcs.net/gershomb/jmacro