jmacro-rpc-0.2: Network/JMacroRPC/Panels.hs
{-# LANGUAGE GADTs, QuasiQuotes, TupleSections, ScopedTypeVariables, NoMonomorphismRestriction, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-}
{- |
Module : Network.JMacroRPC.Panels
Copyright : (c) Gershom Bazerman, 2012
License : BSD 3 Clause
Maintainer : gershomb@gmail.com
Stability : experimental
The Panels library provides continuation-style compositional web
development with no scaling hassle. On the server side, Panels are
entirely stateless, storing no client-specific state. This also means
that requests can be sharded to multiple servers without worrying
about replication of large session objects (authentication choices are
another issue entirely).
Code is written with a set of combinators over `Panel`s,
which package up display and behavior simultaneously. Panels, inspired
by FRP, can provide `Signal`s, which are sampleable, `Event`s, which are
discrete and can trigger updates, and `Sink`s which can be bound to
Signals (behaving similarly to FRP wormholes). Semantics, by virtue of
client-server interaction, are necessarily evented rather than
continuous.
Panels, which are built using this library, can then be displayed using one of a number of servers as backends. New backends can be created with the `panelToPageGen` function.
Example usage:
> testPanel :: (Monad m, Functor m) => Panel m
> testPanel = para "This is an example"
> <> plainHTML Blaze.br
> <> inDiv [
> select ("default",1::Int) [("another",2)] $ \ evt selSignal selPanel ->
> selPanel <>
> (onEvent evt $
> withSample selSignal $ \ selChoice ->
> select (show selChoice, selChoice)
> [(show $ selChoice + 1, selChoice + 1)] $ \ _evt selSignal2 selPanel2 ->
> button "click me" $ \ buttonEvt buttonPanel ->
> onEvent buttonEvt $
> withSample selSignal2 $ \ selChoice2 ->
> (selPanel2 <> buttonPanel <> plainHTML Blaze.br
> <> (para $ "you chose: " ++ show (selChoice, selChoice2))))
> ]
The above code displays two dropdown menus and a button. The first dropdown determines the contents of the second. On clicking the button, the text updates with choices from both the first and second dropdowns.
See the source of `calcPanel` for an example of mixed client/server updates with more complicated stateful interaction.
-}
module Network.JMacroRPC.Panels (
-- * Base Types
JS, Hask, PanelPath,
Event, Signal, Sink,
-- * The PState Monad Transformer
PanelState, PState, newIdent, descended,
-- * Page Slices and Panels
PageSlice(..), Panel(..),
-- * Base Type Combinators
pureSig,
zipSinks,
contramapJs,
-- * Building Panels
plainHTML,
onHtml,
joinWith,
buildInput,
inDiv,
para,
mkTable,
-- * Interacting with signals, sinks, and events
withSample,
sampleSigJs,
onEvent,
tellSink,
bindSigSink,
sampleIO,
bindEventIO,
-- * Derived panels and inputs.
button, select, selectInput, textPane, newVar,
-- * Running Panels
panelPrelude,
panelToPageGen,
-- * Examples
calcPanel
)
where
import Control.Monad.State
import Control.Arrow((***))
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Attoparsec.ByteString.Lazy(parse,Result(..))
import Data.Functor.Contravariant
import Data.Map(Map)
import Data.Set(Set)
import Data.Maybe
import Language.Javascript.JMacro
import Text.Blaze.Html5(Html)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5 as H5
import Text.Blaze.Html5((!),toValue)
import qualified Text.Blaze.Html5.Attributes as H
import Control.Applicative
import Data.Monoid
import Data.List(intercalate)
import Data.String
import Data.Aeson
import Data.Aeson.Parser
import qualified Data.Text.Encoding as T
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
import Network.JMacroRPC.Base
-- | Type tag for Sinks and Signals that can be run in pure JavaScript.
data JS
-- | Type tag for Sinks and Signals that require server-side interaction.
data Hask
-- | Unique label for any given panel in a control structure.
type PanelPath = [Int]
printPath :: PanelPath -> String
printPath = intercalate "_" . map show . reverse
-- | 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.
-- In reality, an event is composed of the panelpaths to it's sources.
data Event = Event [PanelPath]
instance Monoid Event where
mempty = Event []
mappend (Event x) (Event y) = Event (x <> y)
-- This isn't a real functor because fmap id isn't always id.
-- Note that monad breaks inspectability of ids.
-- | A Signal can contain information drawn from client-side inputs. Signals are tagged as JS, Hask, or parametric. A signal of type JS can be read from purely on the client side, with no round trip. A signal of type Hask forms an applicative functor, so we can build server-side values with complex computed behaviours.
-- Note that @Signal Hask@ actually bends the applicative functor laws in that @fmap id@ on a signal that can be calculated directly in JS can send it to a signal that cannot be. This is a flaw, and it will be fixed.
data Signal typ a where
PureSig :: a -> Signal typ a
OneSig :: FromJSON a => PanelPath -> Signal typ a
MultiSig :: Signal typ1 a -> Signal typ2 b -> ((a,b) -> c) -> Signal Hask c
-- TODO, IO Signals?
instance Functor (Signal Hask) where
fmap f (PureSig x) = PureSig $ f x
fmap f (OneSig p) = MultiSig (OneSig p) (PureSig ()) (f . fst)
fmap f (MultiSig x y g) = MultiSig x y (f . g)
instance Applicative (Signal Hask) where
pure x = PureSig x
(PureSig f) <*> x = fmap f x
f <*> (PureSig y) = fmap ($ y) f
f <*> x = MultiSig f x (uncurry ($))
-- | Since only some Signals are applicative functors, pureSig provides a @pure@ operation over all Signals.
pureSig :: a -> Signal typ a
pureSig = PureSig
-- | 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
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 (PureSink js) = ServerSink $ \x -> return [ [jmacro|`(js)` `(x)`|] ]
liftSink (ServerSink f) = ServerSink f
runSink :: Monad m => Sink typ m a -> a -> PState m [JStat]
runSink (ServerSink f) = f
runSink x@(PureSink _) = runSink (liftSink x)
instance Monad m => Contravariant (Sink Hask m) where
contramap f (ServerSink g) = ServerSink (g . f)
contramap f x = contramap f (liftSink x)
-- | A JavaScript funcion can be contravariantly mapped over a Sink JS
contramapJs :: ToJExpr a => JExpr -> Sink JS m b -> Sink JS m a
contramapJs f (PureSink g) = PureSink [jmacroE|\x -> `(g)` (`(f)` x)|]
-- TODO zipsinks over JS sinks too -- use liftsink
-- | We can zip sinks up to combine them.
zipSinks :: Monad m => Sink Hask m a -> Sink Hask m b -> Sink Hask m (a,b)
zipSinks (ServerSink f) (ServerSink g) = ServerSink (\(x,y) -> liftM2 (<>) (f x) (g y))
zipSinks s t = zipSinks (liftSink s) (liftSink t)
extractIds :: Signal typ a -> [PanelPath]
extractIds (PureSig _) = []
extractIds (OneSig p) = [p]
extractIds (MultiSig x y _) = extractIds x <> extractIds y
-- TODO add req environment + maybe refactor the clean/hacked envs
-- | A PanelState contains environment information used to render Panels.
data PanelState = PanelState {
ps_path :: PanelPath,
ps_env :: Map String BS.ByteString, -- including stale parentpaths
ps_env_clean :: Map String BS.ByteString, -- including only fresh parentpaths
ps_events :: Set String,
ps_listener :: Maybe (String, Map String BS.ByteString) --the variable and local env for it if we're in an update context
} deriving (Show)
-- | The PState Monad Transformer provides access o the PanelState.
type PState m a = StateT PanelState m a
readSignal :: (Functor m, Monad m) => Signal typ a -> PState m a
readSignal x = case x of
PureSig v -> return v
OneSig p -> mbParse p . M.lookup (printPath p) . ps_env <$> get
MultiSig sa sb f -> fmap f $ liftA2 (,) (readSignal sa) (readSignal sb)
where mbParse p Nothing = error $ "no value in env for: " ++ printPath p
mbParse _ (Just v) = case parse value v of
Done _ jv -> case fromJSON jv of
Success a -> a
-- This is an ad hoc case to fall back on string decoding. blah.
_ -> case fromJSON (String $ T.decodeUtf8 $ B.concat $ BS.toChunks v) of
Success a -> a
_ -> error $ "unable to parse: " ++ show v
_ -> case fromJSON (String $ T.decodeUtf8 $ B.concat $ BS.toChunks v) of
Success a -> a
_ -> error $ "unable to parse string: " ++ show v
setEnv :: (Functor m, Monad m, ToJSON a) => PanelPath -> a -> PState m ()
setEnv i x = modify (\ps -> ps {ps_env = go (ps_env ps)})
where go = M.insert (printPath i) (encode x)
incrPath :: PanelPath -> PanelPath
incrPath (x:xs) = x + 1 : xs
incrPath [] = []
-- | We can get a fresh identifier out of a panel state.
newIdent :: (Monad m, Functor m) => PState m PanelPath
newIdent = do
i <- ps_path <$> get
modify (\s -> s {ps_path = incrPath i})
return i
-- | 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.
descended :: (Monad m, Functor m) => (PanelPath -> PState m a) -> PState m a
descended f = do
i <- ps_path <$> get
modify (\s -> s {ps_path = 0 : i})
res <- f i
modify (\s -> s {ps_path = incrPath i})
return res
-- | A PageSlice is a pair of Html and JavaScript. When a Panel is rendered,
-- all JavaScript ends up joined together in the head of the page, and all HTML below it. PageSlices are naturally Monoidal, just as Html is.
data PageSlice = PS {
htmlP :: Html,
jsP :: [JStat]
}
instance Monoid PageSlice where
mempty = PS mempty mempty
mappend (PS h j) (PS h' j') = PS (h <> h') (j <> j')
-- | A Panel is the pair of an action to produce a PageSlice and
-- an action to produce a list of locations with updated PageSlices.
-- The former is used to draw the initial page, and the latter to
-- modify it in response to events. Panels are also naturally Monoidal.
data Panel m = Panel {
drawP :: PState m PageSlice,
updateP :: PState m [(PanelPath, PageSlice)]
}
instance Monad m => Monoid (Panel m) where
mempty = Panel (return mempty) (return mempty)
mappend (Panel d u) (Panel d' u') = Panel (liftM2 (<>) d d') (liftM2 (<>) u u')
runPanelDraw :: (Monad m, Functor m) => Map String BS.ByteString -> Set String -> Panel m -> m PageSlice
runPanelDraw m s p = drawP p `evalStateT` startState
where startState = PanelState [0] m m s Nothing
runPanelUpdateSlice :: (Monad m, Functor m) => (String, Map String BS.ByteString) -> Map String BS.ByteString -> Set String -> Panel m -> m [(PanelPath,PageSlice)]
runPanelUpdateSlice (slice, parentData) m s p = updateP p `evalStateT` startState
where startState = PanelState [0] (M.union parentData m) m s (Just (slice, parentData))
runPanelUpdateMany :: (Monad m, Functor m) => Map String BS.ByteString -> Map String (Map String BS.ByteString) -> Set String -> Panel m -> m [(PanelPath,PageSlice)]
runPanelUpdateMany m listenerData s p = concat <$> mapM go (M.toList listenerData)
where go listenerPair = runPanelUpdateSlice listenerPair m s p
-- | We can lift any Html into a Panel trivially.
plainHTML :: (Monad m, Functor m) => Html -> Panel m
plainHTML h = Panel (return $ PS h []) (return [])
onHtmlPS :: (Html -> Html) -> PageSlice -> PageSlice
onHtmlPS f (PS h j) = PS (f h) j
-- | Similarly, we can map over any Html inside a panel (although the behavior may be odd on panels with internal update semantics).
onHtml :: (Monad m, Functor m) => (Html -> Html) -> Panel m -> Panel m
onHtml f (Panel d u) = Panel (fmap (onHtmlPS f) d) u
joinWithPS :: ([Html] -> Html) -> [PageSlice] -> PageSlice
joinWithPS f ps = PS (f $ map htmlP ps) (concatMap jsP ps)
-- | Given a function to join Html sections, we can fuse a list of panels into a single pannel by lifting that function.
joinWith :: (Monad m, Functor m) => ([Html] -> Html) -> [Panel m] -> Panel m
joinWith f xs = Panel (joinWithPS f <$> mapM drawP xs) (concat <$> mapM updateP xs)
-- | Given an arbitrary Signal, and a continuation accepting a value of the underlying type of the signal, yield a simple Panel.
withSample :: (FromJSON a, Monad m, Functor m) => Signal typ a -> (a -> Panel m) -> Panel m
withSample sig k = Panel onDraw onUpdate
where onDraw = descended $ \i -> setDependenciesSig (printPath i) (extractIds sig) <$> ((drawP . k <=< readSignal) sig)
onUpdate = descended $ const $ (updateP . k <=< readSignal) sig
setDependenciesSig :: String -> [PanelPath] -> PageSlice -> PageSlice
setDependenciesSig pathI depList (PS h j) = PS
((H.div ! H.id (toValue pathI) ! H.name (toValue "inp")) h)
(map (\d -> [jmacro|signalDepends(`(pathI)`,`(printPath d)`);|]) depList ++ j)
-- TODO, allow JS signals to not just be .val(), but have arbitrary "getter" actions.
-- | Given a Signal JS, produce a JavaScript expression that samples the value of the signal.
sampleSigJs :: ToJSON a => Signal JS a -> JExpr
sampleSigJs (OneSig ip) = [jmacroE|$("#"+`(ip)`).val()|]
sampleSigJs (PureSig x) = [jmacroE|`(toJSON x)`|]
-- | Given an Event, and a Panel, update the Panel each time the event fires.
onEvent :: (Monad m, Functor m) => Event -> Panel m -> Panel m
onEvent (Event depList) p = Panel onDraw onUpdate
where onDraw = descended $ \i -> do
let ip = printPath i
setDependenciesEvt ip <$> drawP p
setDependenciesEvt pathI (PS h j) = PS
((H.div ! H.id (toValue pathI) ! H.name (toValue "evt")) h)
(map (\d -> [jmacro|eventDepends(`(pathI)`,`(printPath d)`);|]) depList ++ j)
onUpdate = descended $ \i -> do
let ip = printPath i
events <- ps_events <$> get
listener <- fmap fst . ps_listener <$> get
let shouldUpdate = case listener of
Just l -> l == ip
Nothing -> any (`S.member` events) (map printPath depList)
if shouldUpdate
then do
parentDeps <- fromMaybe M.empty . fmap snd . ps_listener <$> get
setCleanState
(\x -> [(i,x)]) . setDependenciesUpd parentDeps ip <$> drawP p
else updateP p
setCleanState = modify (\ps -> ps {ps_env = ps_env_clean ps})
setDependenciesUpd parentData pathI (PS h j) = PS
((H.div ! H.id (toValue pathI) ! H.name (toValue "evt")) h)
(map (\d -> [jmacro|eventDependsPD(`(pathI)`,`(printPath d)`,`(M.map BS.unpack $ parentData)`);|]) depList ++ j)
-- TODO SWITCH FUNCTION
-- | Feed a value to a Sink.
tellSink :: (Functor m, Monad m) => Sink typ m a -> a -> Panel m
tellSink i x = Panel (do
l <- ps_listener <$> get
case l of
-- we're updating
Just _ -> PS mempty <$> runSink i x
-- we're not
Nothing -> return mempty
)
(return [])
-- | 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 [])
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.
-- 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.
-> (Event -> Signal typ a -> sinks -> Panel m -> Panel m) -- ^ given a so-constructed panel, event, and signal, declare what panel to produce.
-> Panel m -- ^ result panel
buildInput mkInput k = Panel onDraw onUpdate
where onDraw = newIdent >>= \i -> do
let (initial, inputs, control) = mkInput i
e = Event [i]
s = OneSig i
p = k e s inputs control
setEnv i initial
descended $ \ i' -> setDependenciesSig (printPath i') [i] <$> drawP p
onUpdate = newIdent >>= \i ->
let (_, inputs, control) = mkInput i
e = Event [i]
s = OneSig i
p = k e s inputs control
in descended $ const $ updateP p
-- NB descending and setting dependencies here is pessimistic w/r/t dependencies. But to be 'exact' we need all deps to propigate up even if guarded by if and case statements -- this means not using real if and case statements.
-- Nonetheless we at least only deliver potential deps and not *all* deps in completely orthogonal areas.
-- Not pessimistic is just avoiding the use of descended and setDependencies
-- | Takes an initial value and a continuation taking an event and the button itself, yields a panel.
button :: (Monad m, Functor m) => String -> (Event -> Panel m -> Panel m) -> Panel m
button txt k = buildInput mkButton kont
where kont e _s _i p = k e p
mkButton i = (
(),
(),
Panel (return $ PS htmlBit jsBit) (return [])
)
where htmlBit = H.button ! H.id (toValue ip) $ fromString txt
jsBit = [[jmacro|registerButton(`(ip)`);|]]
ip = printPath i
-- | Takes an intial (label, value) pair, a list of pairs of labeled values, and a continuation, building a Panel with a dropdown selector.
select :: (Monad m, Functor m, ToJSON a, FromJSON a) => (String, a) -> [(String, a)] -> (Event -> Signal typ a -> Panel m -> Panel m) -> Panel m
select defOpt options k = buildInput mkSelect kont
where kont evt sig _sink p = k evt sig p
mkSelect i = (
snd defOpt,
(),
Panel (return $ PS htmlBit jsBit) (return [])
)
where htmlBit = H.select ! H.id (toValue ip) $ mconcat $ map mkOption (defOpt : options)
mkOption (n,v) = H.option ! H.value (toValue . BS.unpack $ encode v) $ (fromString n)
jsBit = [[jmacro|registerSelect(`(ip)`);|]]
ip = printPath i
--TODO freezeUpdates combinator. renders section fixed -- e.g. one requiring IO or whatever.
--TODO rename to sampleIO
-- | Perform an action in the underlying monad and feed the result to a panel. Synchronous.
-- Note that this action will occur on every update, even when guarded by an onEvent.
sampleIO :: (Monad m) => m a -> (a -> Panel m) -> Panel m
sampleIO act k = Panel onDraw onUpdate
where onDraw = drawP . k =<< lift act
onUpdate = updateP . k =<< lift act
-- | Execute an IO action when triggered by an event. This action only occurs when the event fires.
-- @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
selectInput defOpt opts k = select defOpt opts $ \e sig p -> withSample sig $ \i -> k e i p
-- TODO make letters more uniform for argument types
-- | A basic text input box. This box provides a Sink as well as a Signal, so it's contents can be controlled from elsewhere in the Panel.
textPane :: (Monad m, Functor m) => String -> (Event -> Signal typ String -> Sink typ m String -> Panel m -> Panel m) -> Panel m
textPane initial kont = buildInput mkInput kont
where mkInput i = (
initial,
input,
Panel (return $ PS htmlBit jsBit) (return [])
)
where htmlBit = H.input ! H.id (toValue ip) ! H.value (toValue initial)
jsBit = [[jmacro|registerInput(`(ip)`);|]]
ip = printPath i
input = PureSink [jmacroE|\x -> $("#"+`(ip)`).val(x)|]
-- | A hidden input Panel that can be used as a mutable store, akin to an IORef or MVar.
newVar :: (Monad m, Functor m, ToJSON a, FromJSON a, ToJExpr a) => a -> (Event -> Signal typ a -> Sink typ m a -> Panel m -> Panel m) -> Panel m
newVar initial kont = buildInput mkInput kont
where mkInput i = (
initial,
input,
Panel (return $ PS htmlBit jsBit) (return [])
)
where htmlBit = H.input ! H.hidden (toValue True) ! H.id (toValue ip) ! H.value (toValue . BS.unpack $ encode initial)
jsBit = [[jmacro|registerInput(`(ip)`);|]]
ip = printPath i
input = PureSink [jmacroE|\x -> $("#"+`(ip)`).val(JSON.stringify(x))|]
-- lifted html combinator toys
-- | Put a bunch of panels into a single div element.
-- @inDiv = onHtml H.div . mconcat@
inDiv :: (Monad m, Functor m) => [Panel m] -> Panel m
inDiv = onHtml H.div . mconcat
-- | 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
-- | Align a list of panels into a table with rows of the specified width.
-- @mkTable n xs = onHtml H.table . mconcat . map row $ chunksOf n xs
-- where row ys = onHtml H.tr . mconcat $ map (onHtml H.td) ys@
mkTable :: (Monad m, Functor m) => Int -> [Panel m] -> Panel m
mkTable n xs = onHtml H.table . mconcat . map row $ chunksOf n xs
where row ys = onHtml H.tr . mconcat $ map (onHtml H.td) ys
-- | JavaScript code for the reactive runtime system.
panelPrelude :: JStat
panelPrelude = [jmacro|
fun setInsert set val { set[val] = true; return set; }
fun setInsertMany set newset {
for(var n in newset) {
set[n] = true;
}
return set;
}
fun setDeleteMany set newset {
for(var n in newset) {
delete set[n];
}
return set;
}
fun nullSet set {
for(k in set) {
return false;
}
return true;
}
fun setToList set {
var lst = [];
for(k in set) {
lst.push(k);
}
return lst;
}
fun insertMapSet ms k v {
if(typeof ms[k] == "undefined") {
ms[k] = {}
}
setInsert(ms[k],v);
return ms;
}
fun insertMapMap ms k k1 v {
if(typeof ms[k] == "undefined") {
ms[k] = {}
}
ms[k][k1] = v;
return ms;
}
// Map IDPath (Set IDPath)
// :: Map Event DependentSections
var !eventToDepsMap = {};
// Map Section DataRequired
// signalMap :: Map IDPath (Set IDPath)
var !sectToSigsMap = {};
// Map IDPath (Set IDPath)
var !listenerToParentDataMap = {};
// Map IDPath (Map IDPath (() -> IO ()))
var !eventToClientDepsMap = {};
// IDPath -> Set IDPath
fun subsetIDMapFromPfx pfx mp {
var pfl = pfx.length;
var res = {};
for (var idp in mp) {
if(idp.slice(0,pfl) == pfx) {
setInsertMany res mp[idp];
}
}
return res;
}
// -- TODO we don't need to iterate over the whole mp, just parent keys.
// -- Given a path, if any prefix of the path matches a key
// -- then add the elements of that key.
// IDPath -> Set IDPath
fun parentsIDMapFromPfx pfx mp {
var res = {};
for (var idp in mp) {
if(pfx.slice(0,idp.length) == idp) {
setInsertMany res mp[idp];
}
}
return res;
}
fun signalDepends listenerId signalId -> insertMapSet sectToSigsMap listenerId signalId;
// -- Initial write, put fresh map
fun eventDepends listenerId eventID {
insertMapSet eventToDepsMap eventID listenerId;
var parentDeps = parentsIDMapFromPfx listenerId sectToSigsMap;
var parentMap = {};
for(var p in parentDeps) {
parentMap[p] = $("#"+p).val();
}
listenerToParentDataMap[listenerId] = parentMap;
}
// -- Subsequent writes, put
fun eventDependsPD listenerId eventId parentData {
insertMapSet eventToDepsMap eventId listenerId;
listenerToParentDataMap[listenerId] = parentData;
}
fun clientEventDepends listenerId eventId js {
insertMapMap eventToClientDepsMap eventId listenerId js;
}
fun invalidateRegion(uid) {
var pfl = uid.length;
var subSects = {};
setInsert subSects uid;
for(var sect in sectToSigsMap) {
if(sect.slice(0,pfl) == uid) {
setInsert subSects sect;
delete sectToSigsMap[sect];
}
}
// -- it *should* be true that there are no listners that are not subs? If not, there's this
for(var sect in sectToSigsMap) {
setDeleteMany sectToSigsMap[sect] subSects;
}
// -- each uid + all subs no longer provide events
var subEvts = {};
setInsert subEvts uid;
for(var evt in eventToDepsMap) {
if(evt.slice(0,pfl) == uid) {
setInsert subEvts evt;
delete eventToDepsMap[evt];
}
}
// -- each uid + all subs can no longer be dependencies *of* events
for(var evt in eventToDepsMap) {
setDeleteMany eventToDepsMap[evt] subEvts;
}
// -- each listener no longer needs its parent data
for(var listener in listenerToParentDataMap) {
if(listener.slice(0,pfl) == uid) {
delete listener listenerToParentDataMap;
}
}
// -- each client listener goes away
for(var evt in eventToClientDepsMap) {
if(evt.slice(0,pfl) == uid) {
eventToClientDepsMap[evt] = {};
}
for(var listener in eventToClientDepsMap[evt]) {
if(listener.slice(0,pfl) == uid) {
delete listener eventToClientDepsMap[evt];
}
}
}
}
fun executeUpdate(ups) {
for(var i in ups) {
var [uid,[upane,ujs]] = ups[i];
// -- Invalidate Deps
invalidateRegion(uid);
// -- Insert new Html
$("#"+uid).html(upane);
// -- Perform new JS
eval(ujs);
}
}
fun registerButton b -> $("#"+b).data("isButton",true);
fun registerSelect s -> $("#"+s).data("isSelect",true);
fun registerInput s -> $("#"+s).data("isTextInput",true);
fun fireEvent uid {
console.log("fireevent",uid);
// -- A set of everything depending on the event.
var deps = eventToDepsMap[uid];
var depsExist = false;
// -- The set of data trails leading to each dep
var depDataMap = {};
// -- The set of everything that things depending on the event or their children need in order to generate. Also the things their parents may pull.
var sectData = {};
for (var dep in deps) {
depsExist = true;
setInsertMany sectData (subsetIDMapFromPfx dep sectToSigsMap);
setInsertMany sectData (parentsIDMapFromPfx dep sectToSigsMap);
depDataMap[dep] = listenerToParentDataMap[dep];
}
// -- Clientside handlers
var clientDeps = eventToClientDepsMap[uid] == null ? {} : eventToClientDepsMap[uid];
console.log("clientDeps",clientDeps);
for (var cdep in clientDeps) {
console.log("cdep",clientDeps[cdep]);
clientDeps[cdep]();
}
var envMap = {};
for(var s in sectData) {
envMap[s] = $("#"+s).val();
}
if(depsExist) {
executeUpdate (updateEvent(envMap,depDataMap,[uid]));
}
}
fun handleButton e {
var tg = $(e.target);
if(tg.data("isButton")) {
fireEvent(tg.attr("id"));
}
}
$("html").on("click", "button", handleButton);
fun handleSelect e {
var tg = $(e.target);
if(tg.data("isSelect")) {
fireEvent(tg.attr("id"));
}
}
$("html").on("change", "select", handleSelect);
fun handleInput e {
var tg = $(e.target);
if(tg.data("isTextInput")) {
fireEvent(tg.attr("id"));
}
}
$("html").on("change", "input", handleInput);
|]
type UpdateList = [(String, (String,String))]
-- TODO NOW. fix other modules to use simplified panelToPageGen
-- | General function used to create backends for different servers and frameworks.
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.
-> String -- ^ A page title.
-> 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)
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 . fromString . show . renderJs $ invokeRPCLib `mappend` rpcDecls `mappend` panelPrelude
H.script . fromString . show . renderJs . wrapJQuery . jsP $ dp
H.body . htmlP $ dp
wrapJQuery jm = [jmacroE|$(\ {`(jm)`;})|]
updateHandler = serveRpcs allRPCs
allRPCs = [updateRPC]
rpcDecls = mconcat $ map jsonRPCToDecl allRPCs
updateFun :: Map String BS.ByteString -> Map String (Map String BS.ByteString) -> Set String -> m (Either String UpdateList)
updateFun envMap listenerData eventSet = do
slices <- runPanelUpdateMany envMap listenerData eventSet p
return $ Right $ map (printPath *** renderPS) $ slices
renderPS ps = (P.renderHtml . htmlP $ ps,
show . renderJs . mconcat . jsP $ ps)
updateRPC :: JsonRPC m ()
updateRPC = toJsonRPC "updateEvent" $ \envMap depDataMap eventSet -> updateFun envMap depDataMap eventSet
-- TODO more interesting control with inputs, like a dial or something.
--TODO define function composition combinator
-- | Example panel that displays a calculator.
calcPanel :: (Monad m, Functor m) => Panel m
calcPanel = textPane "0" $ \_ displaysig displayInp displaypane ->
newVar "0" $ \_ storesig storeInp storepane ->
newVar "" $ \_ cmdstoresig cmdstoreInp cmdstorepane ->
let
trimJs = [jmacroE|\x {for(var i = 0; i<x.length;i++) {
if(x[i] != '0') { return x.substring(i,x.length)}
}
return 0;}|]
addDisplayInp = contramapJs [jmacroE|\x -> `(trimJs)` (`(sampleSigJs displaysig)` + x)|] displayInp
numButton val = button val $ \ e b -> b <> bindSigSink e (pureSig val) addDisplayInp
opButton val = button val $ \ e b -> b <> bindSigSink e (pureSig val) cmdstoreInp
<> bindSigSink e displaysig storeInp
<> bindSigSink e (pureSig "0") displayInp
clearButton = button "c" $ \ e b -> b <>
bindSigSink e (pureSig "0") storeInp <>
bindSigSink e (pureSig "0") displayInp <>
bindSigSink e (pureSig "") cmdstoreInp
equalButton = button "=" $ \ e b -> b <> onEvent e
(withSample cmdstoresig $ \cmdstoreval ->
withSample displaysig $ \dispval ->
withSample storesig $ \storeval ->
let execOp op = tellSink displayInp (show $ (read storeval :: Int) `op` (read dispval :: Int))
in case cmdstoreval of
"+" -> execOp (+)
"-" -> execOp (flip subtract)
"*" -> execOp (*)
"/" -> execOp (div)
_ -> mempty)
buttonPane = mkTable 3 $ map (numButton . show) ([(1::Int)..9] ++ [0]) ++ map opButton ["+","-","*","/"] ++ [equalButton,clearButton]
in
inDiv [displaypane <> storepane <> cmdstorepane,
buttonPane
]
--TODO arbitrary typeclass driven pane manipulation?