Commit e5c6bfa6 authored by Bas Lijnse's avatar Bas Lijnse

Added a 'multiple' function for dynamic groups

parent 353e64db
Pipeline #17876 failed with stage
in 1 minute and 14 seconds
module EditorSim
/**
* Simulation of messages passing between editors to figure out the design details
* Simulation of messages passing between editors to figure out the design details
*/
import iTasks
import Data.Maybe, Data.Either, Data.Functor
import Data.Maybe, Data.Either, Data.Tuple, Data.Functor, Data.List
import qualified Data.Map as DM
import Text, Text.HTML
......@@ -14,7 +14,7 @@ import Text, Text.HTML
// w: Data to be written back to the external source (sds)
// s: Server-side state
// c: Client-side state
// c: Client-side state
// m: Messages exchanged to synchronize between client and server (and potentially between sub editors)
:: NxtEditor p r w s c m =
......@@ -33,13 +33,30 @@ import Text, Text.HTML
{ init :: p -> (s,c)
, parameter :: s -> p
, value :: s -> Maybe w
, onRefresh :: r s -> ([m], s, Bool)
, onRefresh :: r s -> ([m], s, Bool) //The Bool is a 'write' signal that indicates if something significant has changed
, onMessage :: m s -> ([m], s, Bool)
}
//Simulated DOM/JSWorld
:: NxtDOMRef :== [Int]
:: NxtDOM :== Map String String
:: NxtDOMRef :== Int
:: NxtDOM :== Map String String
newDOMRef :: NxtDOM -> (NxtDOMRef,NxtDOM)
newDOMRef dom
# n = maybe 0 toInt ('DM'.get "nextREF" dom) + 1
= (n,'DM'.put "nextREF" (toString n) dom)
//Util
getDOMChildren :: NxtDOMRef NxtDOM -> ([NxtDOMRef],NxtDOM)
getDOMChildren ref dom
= (fromMaybe [] (maybe Nothing (fromJSON o fromString) ('DM'.get (domRef "children" ref) dom)), dom)
setDOMChildren :: [NxtDOMRef] NxtDOMRef NxtDOM -> NxtDOM
setDOMChildren children ref dom
= 'DM'.put (domRef "children" ref) (toString (toJSON children)) dom
domRef attr ref = toString ref +++ "-" +++ attr
//Untyped clientside configuration
:: NxtUI :== Map String String
......@@ -52,7 +69,7 @@ import Text, Text.HTML
:: NxtAttrChange = NxtSetAttr String String | NxtDelAttr String
:: NxtStructureChange
= NxtAddChild Int NxtUI
= NxtAddChild Int NxtUI
| NxtRemChild Int
| NxtUpdChild Int NxtChange
......@@ -70,20 +87,20 @@ where
client = {init=init,onEvent=onEvent,onMessage=onMessage,state=state}
where
init c ref dom
= 'DM'.put ("value-" +++ join "-" (map toString ref)) (fromString c) dom
= 'DM'.put (domRef "value" ref) (fromString c) dom
onEvent (eref,e) ref dom
| eref =!= ref = ([],dom)
| eref <> ref = ([],dom)
# msg = [e]
# dom = 'DM'.put ("value-" +++ join "-" (map toString ref)) (fromString e) dom
# dom = 'DM'.put (domRef "value" ref) (fromString e) dom
= (msg,dom)
onMessage m ref dom
# dom = 'DM'.put ("value-" +++ join "-" (map toString ref)) m dom
# dom = 'DM'.put (domRef "value" ref) m dom
= ([],dom)
state ref dom
= (fromMaybe "A" ('DM'.get ("value-" +++ join "-" (map toString ref)) dom),dom)
= (fromMaybe "A" ('DM'.get (domRef "value" ref) dom),dom)
server = {init=init,parameter=parameter,value=value,onRefresh=onRefresh,onMessage=onMessage}
where
......@@ -100,25 +117,25 @@ where
client = {init=init,onEvent=onEvent,onMessage=onMessage,state=state}
where
init (label,clicked) ref dom
# dom = 'DM'.put ("label-" +++ join "-" (map toString ref)) label dom
# dom = 'DM'.put ("clicked-" +++ join "-" (map toString ref)) (if clicked "true" "false") dom
# dom = 'DM'.put (domRef "label" ref) label dom
# dom = 'DM'.put (domRef "clicked" ref) (if clicked "true" "false") dom
= dom
onEvent (eref,"click") ref dom
| eref =!= ref = ([],dom)
# msg = [True]
# dom = 'DM'.put ("clicked-" +++ join "-" (map toString ref)) "true" dom
# dom = 'DM'.put (domRef "clicked" ref) "true" dom
= (msg,dom)
onMessage m ref dom
# dom = 'DM'.put ("clicked-" +++ join "-" (map toString ref)) (if m "true" "false") dom
# dom = 'DM'.put (domRef "clicked" ref) (if m "true" "false") dom
= ([],dom)
state ref dom
# clicked = case 'DM'.get ("clicked-" +++ join "-" (map toString ref)) dom of
# clicked = case 'DM'.get (domRef "clicked" ref) dom of
(Just "true") = True
_ = False
# label = fromJust ('DM'.get ("label-" +++ join "-" (map toString ref)) dom)
# label = fromJust ('DM'.get (domRef "label" ref) dom)
= ((label,clicked),dom)
server = {init=init,parameter=parameter,value=value,onRefresh=onRefresh,onMessage=onMessage}
......@@ -155,7 +172,8 @@ where
// Composition
//Compose by juxtaposition, no need to specify interdependency
glue :: (NxtEditor p1 r1 w1 s1 c1 m1)
glue ::
(NxtEditor p1 r1 w1 s1 c1 m1)
(NxtEditor p2 r2 w2 s2 c2 m2)
->
(NxtEditor (p1,p2) (r1,r2) (Maybe w1, Maybe w2) (s1,s2) (c1,c2) (Maybe m1, Maybe m2))
......@@ -166,13 +184,13 @@ where
init (p1,p2)
# (s1,c1) = e1.server.NxtEditorServer.init p1
# (s2,c2) = e2.server.NxtEditorServer.init p2
= ((s1,s2),(c1,c2))
= ((s1,s2),(c1,c2))
parameter (s1,s2) = (e1.server.NxtEditorServer.parameter s1, e2.server.NxtEditorServer.parameter s2)
value (s1,s2) = case (e1.server.NxtEditorServer.value s1, e2.server.NxtEditorServer.value s2) of
(Nothing,Nothing) = Nothing
(mb1,mb2) = Just (mb1,mb2)
(mb1,mb2) = Just (mb1,mb2)
onRefresh (s1n,s2n) (s1o,s2o)
# (m1, s1, w1) = e1.server.NxtEditorServer.onRefresh s1n s1o
......@@ -186,24 +204,31 @@ where
client = {init=init,onEvent=onEvent,onMessage=onMessage,state=state}
where
init (c1,c2) ref dom = e2.client.NxtEditorClient.init c2 (ref ++ [1]) (e1.client.NxtEditorClient.init c1 (ref ++ [0]) dom)
init (c1,c2) ref dom
# (r1,dom) = newDOMRef dom
# (r2,dom) = newDOMRef dom
# dom = setDOMChildren [r1,r2] ref dom
= e2.client.NxtEditorClient.init c2 r2 (e1.client.NxtEditorClient.init c1 r1 dom)
onEvent event ref dom
# (m1,dom) = e1.client.NxtEditorClient.onEvent event (ref ++ [0]) dom
# (m2,dom) = e2.client.NxtEditorClient.onEvent event (ref ++ [1]) dom
# ([r1,r2:_],dom) = getDOMChildren ref dom
# (m1,dom) = e1.client.NxtEditorClient.onEvent event r1 dom
# (m2,dom) = e2.client.NxtEditorClient.onEvent event r2 dom
= (zipMessages m1 m2, dom)
onMessage (mb1,mb2) ref dom
# (m1,dom) = maybe ([],dom) (\m1 -> e1.client.NxtEditorClient.onMessage m1 (ref ++ [0]) dom) mb1
# (m2,dom) = maybe ([],dom) (\m2 -> e2.client.NxtEditorClient.onMessage m2 (ref ++ [1]) dom) mb2
# ([r1,r2:_],dom) = getDOMChildren ref dom
# (m1,dom) = maybe ([],dom) (\m1 -> e1.client.NxtEditorClient.onMessage m1 r1 dom) mb1
# (m2,dom) = maybe ([],dom) (\m2 -> e2.client.NxtEditorClient.onMessage m2 r2 dom) mb2
= (zipMessages m1 m2, dom)
state ref dom
# (c1,dom) = e1.client.NxtEditorClient.state (ref ++ [0]) dom
# (c2,dom) = e2.client.NxtEditorClient.state (ref ++ [1]) dom
# ([r1,r2:_],dom) = getDOMChildren ref dom
# (c1,dom) = e1.client.NxtEditorClient.state r1 dom
# (c2,dom) = e2.client.NxtEditorClient.state r2 dom
= ((c1,c2),dom)
zipMessages [x:xs] [y:ys] = [(Just x, Just y):zipMessages xs ys]
zipMessages [x:xs] [y:ys] = [(Just x, Just y):zipMessages xs ys]
zipMessages [] ys = [(Nothing,Just y) \\ y <- ys]
zipMessages xs [] = [(Just x,Nothing) \\ x <- xs]
......@@ -216,29 +241,29 @@ link ::
//Rewrite from server to client with feedback to server
(s1 s2 (Maybe m1, Maybe m2) -> ([(Maybe m1, Maybe m2)],[(Maybe m1, Maybe m2)]))
//Rewrite from client to server with feedback to client
(c1 c2 (Either m1 m2) -> ([Either m1 m2],[Either m1 m2]))
(c1 c2 (Either m1 m2) -> ([Either m1 m2],[Either m1 m2]))
(NxtEditor p r (Maybe w1, Maybe w2) (s1,s2) (c1,c2) (Maybe m1, Maybe m2))
->
->
(NxtEditor p r (Maybe w1, Maybe w2) (s1,s2) (c1,c2) (Maybe m1, Maybe m2))
link modClientInit modServerToClient modClientToServer editor = {NxtEditor|server=server,client=client}
where
server = {init=init,parameter=parameter,value=value,onRefresh=onRefresh,onMessage=onMessage}
where
init p
init p
# (s,c) = editor.server.NxtEditorServer.init p
= (s,modClientInit c)
parameter = editor.server.NxtEditorServer.parameter
value = editor.server.NxtEditorServer.value
onRefresh sn so
onRefresh sn so
# (msgs,(s1,s2),mbw) = editor.server.NxtEditorServer.onRefresh sn so
# (msgs,(s1,s2),mbwm) = foldl modifyMsg ([],(s1,s2),False) msgs
= (msgs, (s1,s2),mbw || mbwm)
onMessage m s
# (msgs,(s1,s2), mbw) = editor.server.NxtEditorServer.onMessage m s
# (msgs,(s1,s2), mbw) = editor.server.NxtEditorServer.onMessage m s
# (msgs,(s1,s2), mbwm) = foldl modifyMsg ([],(s1,s2),False) msgs
= (msgs,(s1,s2), mbw || mbwm)
......@@ -247,7 +272,7 @@ where
# (passOn,feedBack) = modServerToClient s1 s2 msg
//Feedback messages
# (feedbackOutput,(s1,s2),mbwm) = foldl feedBackMsg ([],(s1,s2),False) feedBack
= (msgs ++ passOn ++ feedbackOutput, (s1,s2), mbw || mbwm)
= (msgs ++ passOn ++ feedbackOutput, (s1,s2), mbw || mbwm)
feedBackMsg (msgs,(s1,s2),mbw) msg
# (emsgs,(s1,s2),mbwm) = onMessage msg (s1,s2)
......@@ -284,7 +309,7 @@ where
fromEither (Right m2) = (Nothing,Just m2)
//Get rid of the tupling and combine the parts into a unified state, configuration and values
fuse ::
fuse ::
((p1,p2) -> p, p -> (p1,p2)) //Fuse parameter
((Maybe w1, Maybe w2) -> w, r -> (r1,r2)) //Fuse read/write //FIXME
((c1,c2) -> c, c -> (c1,c2)) //Fuse client configuration
......@@ -292,7 +317,7 @@ fuse ::
((Maybe m1, Maybe m2) -> (Maybe m), m -> (Maybe m1, Maybe m2)) //Fuse messages
(NxtEditor (p1,p2) (r1,r2) (Maybe w1, Maybe w2) (s1,s2) (c1,c2) (Maybe m1, Maybe m2))
->
->
(NxtEditor p r w s c m)
fuse (pfrom,pto) (wfrom,rto) (cfrom,cto) (sfrom,sto) (mfrom,mto) editor = {NxtEditor|server=server,client=client}
......@@ -305,7 +330,7 @@ where
# (msgs,dom) = editor.client.NxtEditorClient.onEvent event ref dom
= ([x \\ Just x <- map mfrom msgs],dom)
onMessage msg ref dom
onMessage msg ref dom
# (msgs,dom) = editor.client.NxtEditorClient.onMessage (mto msg) ref dom
= ([x \\ Just x <- map mfrom msgs],dom)
......@@ -331,12 +356,105 @@ where
# (msgs,s,w) = editor.server.NxtEditorServer.onMessage (mto msg) (sto s)
= ([x \\ Just x <- map mfrom msgs],sfrom s, w)
//Turn a single editor into an editor for multiple elements of the same type
:: ContainerMsg c m
//From server to client
= NxtInsertChild Position c
| NxtRemoveChild Position
| NxtUpdateChild Position m
//We don't need explicit messages from client to server, because we'll use other components to control the container
:: Position :== Int
multiple :: (NxtEditor p r w s c m) -> (NxtEditor p [Maybe r] [Maybe w] (p,[s]) [c] (ContainerMsg c m))
multiple editor = {NxtEditor|server=server,client=client}
where
client = {init = init, onEvent = onEvent, onMessage = onMessage, state = state}
where
init cs ref dom
# (rs,dom) = foldl init` ([],dom) cs
= setDOMChildren (reverse rs) ref dom
where
init` (rs,dom) c
# (r,dom) = newDOMRef dom
= ([r:rs],editor.client.NxtEditorClient.init c r dom)
onEvent event ref dom
# (rs,dom) = getDOMChildren ref dom
# (ms,dom) = foldl onEvent` ([],dom) rs
= (flatten [map (NxtUpdateChild i) m \\ m <- reverse ms & i <- [0..]], dom)
where
onEvent` (ms,dom) cref
# (m,dom) = editor.client.NxtEditorClient.onEvent event cref dom
= ([m:ms],dom)
onMessage (NxtInsertChild pos c) ref dom
# (rs,dom) = getDOMChildren ref dom
# (r,dom) = newDOMRef dom
# dom = editor.client.NxtEditorClient.init c r dom
# dom = setDOMChildren (insertAt pos r rs) ref dom
= ([],dom)
onMessage (NxtRemoveChild pos) ref dom
# (rs,dom) = getDOMChildren ref dom
# dom = setDOMChildren (removeAt pos rs) ref dom //No garbage collection, we just remove the reference.
= ([],dom)
onMessage (NxtUpdateChild pos m) ref dom
# (rs,dom) = getDOMChildren ref dom
# (ms,dom) = editor.client.NxtEditorClient.onMessage m (rs !! pos) dom
= ([NxtUpdateChild pos m \\ m <- ms], dom)
state ref dom
# (rs,dom) = getDOMChildren ref dom
# (cs,dom) = foldl state` ([],dom) rs
= (reverse cs, dom)
where
state` (cs,dom) ref
# (c,dom) = editor.client.NxtEditorClient.state ref dom
= ([c:cs],dom)
server = {init = init, parameter = parameter, value=value, onRefresh = onRefresh, onMessage = onMessage}
where
init p = ((p,[]),[])
parameter (p,_) = p
value (_,ss) = Just (map editor.server.NxtEditorServer.value ss)
onRefresh mbrs (p,ss) //A naive linear side by side diff to see what needs updating
# (msgs,ss,write) = compare 0 ss mbrs
= ([], (p,ss), False)//By default we need to do a diff
where
//Compare first items side by side
compare i [s:ss] [Nothing:mbrs]
# (msgs, ss, write) = compare (i + 1) ss mbrs
= (msgs, [s:ss], write)
compare i [s:ss] [Just r:mbrs]
# (ms, s, writes) = editor.server.NxtEditorServer.onRefresh r s
# (msgs, ss, writess) = compare (i + 1) ss mbrs
= (map (NxtUpdateChild i) ms ++ msgs, [s:ss], writes || writess)
//New read list has more items
compare i [] mbrs
# (msgs, ss, ws) = unzip3 [create i` mbr \\ mbr <- mbrs & i` <- [i..]]
= (flatten msgs, ss, or ws)
where
create i mbr
# (s,c) = editor.server.NxtEditorServer.init p
# (ms, s, write) = maybe ([],s,False) (\r -> editor.server.NxtEditorServer.onRefresh r s) mbr
= ([NxtInsertChild i c: map (NxtUpdateChild i) ms], s, write)
//New read list has less (remove existing)
compare i ss [] = (repeatn (length ss) (NxtRemoveChild i),[],False)
onMessage (NxtUpdateChild pos m) (p,ss) //Route to the corresponding child
| pos >= length ss || pos < 0 = ([],(p,ss),False) //Out of bounds, (maybe abort instead for the simulation)
# (ms,s,write) = editor.server.NxtEditorServer.onMessage m (ss !! pos)
= (map (NxtUpdateChild pos) ms, (p, updateAt pos s ss), write)
//Simulation
simulate :: (NxtEditor p r w s c m) p (Maybe r) -> Task () | iTask r & iTask w & iTask s & iTask c & iTask m & EditMessage m
simulate editor p mbr
= withShared initNetworkState
\networkState ->
withShared initServerState
withShared initServerState
\serverState ->
withShared initClientState
\clientState ->
......@@ -349,7 +467,7 @@ where
where
initStates
# (s,c) = editor.server.NxtEditorServer.init p
# cs = editor.client.NxtEditorClient.init c [1] 'DM'.newMap
# cs = editor.client.NxtEditorClient.init c 0 'DM'.newMap
# (s2c,s,_) = maybe ([],s,False) (\r -> editor.server.NxtEditorServer.onRefresh r s) mbr
= (cs,s,(map encodeEditMessage s2c,[]))
......@@ -365,7 +483,7 @@ where
= enterInformation "Enter the refresh value" []
>>= \v -> upd (setStates v) (serverState >*< networkState)
where
setStates v (s,(s2c,c2s))
setStates v (s,(s2c,c2s))
# (msgs,s,mbw) = editor.server.NxtEditorServer.onRefresh v s
= (s, (s2c ++ map encodeEditMessage msgs, c2s))
......@@ -373,17 +491,17 @@ where
= upd setStates (serverState >*< networkState)
where
setStates (s,(s2c,c2s)) = case c2s of
[m:ms]
[m:ms]
# (msgs,s,mbw) = editor.server.NxtEditorServer.onMessage (decodeEditMessage m) s
= (s, (s2c ++ map encodeEditMessage msgs,ms))
_
= (s, (s2c ++ map encodeEditMessage msgs,ms))
_
= (s,(s2c,c2s))
viewNetwork networkState
= viewSharedInformation (Title "Network") [] networkState
simulateClient editor clientState networkState
= viewSharedInformation (Title "Client") [ViewAs clientView] clientState
= viewSharedInformation (Title "Client") [ViewAs clientView] clientState
>^* [OnAction (Action "Event") (always (doClientEvent <<@ InWindow))
,OnAction (Action "Message") (always doClientMessage)
]
......@@ -396,17 +514,17 @@ where
>>= \e -> upd (setStates e) (clientState >*< networkState)
where
setStates e (dom,(s2c,c2s))
# (msgs,dom) = editor.client.onEvent e [1] dom
# (msgs,dom) = editor.client.onEvent e 0 dom
= (dom,(s2c,c2s ++ map encodeEditMessage msgs))
doClientMessage
= upd setStates (clientState >*< networkState)
where
setStates (dom,(s2c,c2s)) = case s2c of
[m:ms]
# (msgs,dom) = editor.client.NxtEditorClient.onMessage (decodeEditMessage m) [1] dom
= (dom,(ms, c2s ++ map encodeEditMessage msgs))
_
[m:ms]
# (msgs,dom) = editor.client.NxtEditorClient.onMessage (decodeEditMessage m) 0 dom
= (dom,(ms, c2s ++ map encodeEditMessage msgs))
_
= (dom,(s2c,c2s))
......@@ -417,14 +535,14 @@ where
s2c _ _ msg = ([msg],[])
//Update the value, when the button is clicked
c2s c1 c2 (Right True) = let n = fromInt (toInt c1 + 1) in ([Left n],[Right False,Left n])
c2s c1 c2 (Right True) = let n = fromInt (toInt c1 + 1) in ([Left n],[Right False,Left n])
c2s c1 c2 msg = ([msg],[])
//Only expose the number field
fusec = (fst, \x -> (x,("Increment",False)))
fuses = (fst, \x -> (x,False))
fusem = (fst,\x -> (Just x,Nothing))
fusem = (fst,\x -> (Just x,Nothing))
fusep = (const (), const ((),()))
fusew = fst
fuser x = (x,False)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment