Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/eXene/widgets/basics/router.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/widgets/basics/router.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* router.sml
2 :     *
3 :     * COPYRIGHT (c) 1991 by AT&T Bell Laboratories See COPYRIGHT file for details.
4 :     *
5 :     * Generic event routers.
6 :     *)
7 :    
8 :     signature ROUTER =
9 :     sig
10 :    
11 :     structure EXB : EXENE_BASE
12 :     structure Interact : INTERACT
13 :    
14 :     exception NotFound
15 :    
16 :     type router
17 :    
18 :     val mkRouter : Interact.in_env * Interact.out_env *
19 :     (EXB.window * Interact.out_env) list -> router
20 :    
21 :     val addChild : router -> EXB.window * Interact.out_env -> unit
22 :     val delChild : router -> EXB.window -> unit
23 :     val getChildEnv : router -> EXB.window -> Interact.out_env
24 :     (* Return environment associated in router with given window.
25 :     * Raise NotFound if not found.
26 :     *)
27 :    
28 :     val routePair : Interact.in_env * Interact.out_env * Interact.out_env -> unit
29 :    
30 :     end (* ROUTER *)
31 :    
32 :     structure Router : ROUTER = struct
33 :    
34 :     structure EXB = EXeneBase
35 :     structure Interact = Interact
36 :    
37 :     exception NotFound
38 :    
39 :     open CML EXeneBase Interact
40 :    
41 :     datatype route_req =
42 :     AddChild of (window * out_env)
43 :     | DelChild of window
44 :     | GetChild of window
45 :    
46 :     datatype router = Router of {
47 :     reqch : route_req chan,
48 :     replych : out_env option chan
49 :     }
50 :    
51 :     (* The router is constructed with an in_env, out_env for a
52 :     * composite widget and an initial distribution
53 :     * list. The router listens for an event on the input environment,
54 :     * resolves the event to an output environment, and passes the event
55 :     * along.
56 :     *)
57 :     fun mkRouter (InEnv{m, k, ci,...}, myOut, outList) = let
58 :     val routeReqCh = channel() and routeReplyCh = channel()
59 :    
60 :     val winMap = newMap()
61 :     val find = lookup winMap
62 :     (* val findMsg = addrLookup winMap *)
63 :     fun findMsg m = addrLookup winMap m
64 :     val insert = insert winMap
65 :     val remove = remove winMap
66 :    
67 :     fun mEvt (OutEnv {m,...}) = m
68 :     fun kEvt (OutEnv {k,...}) = k
69 :     fun ciEvt (OutEnv {ci,...}) = ci
70 :    
71 :     fun handleReq (AddChild item) = insert item
72 :     | handleReq (DelChild w) = ((remove w; ()) handle _ => ())
73 :     | handleReq (GetChild w) = send(routeReplyCh, (SOME(find w)) handle _ => NONE)
74 :    
75 :     fun handleEvt proj msg = (
76 :     case stripMsg msg of
77 :     Here _ => select [
78 :     proj myOut msg,
79 :     wrap (recvEvt routeReqCh, fn req => (handleReq req; handleEvt proj msg))
80 :     ]
81 :     | ToChild msg' => sync (proj (findMsg msg') msg'))
82 :    
83 :     val evt = choose [
84 :     wrap (recvEvt routeReqCh, handleReq),
85 :     wrap (m, handleEvt mEvt),
86 :     wrap (k, handleEvt kEvt),
87 :     wrap (ci, handleEvt ciEvt)
88 :     ]
89 :    
90 :     fun loop () = (sync evt; loop ())
91 :     fun init [] = ()
92 :     | init (item::rest) = (insert item; init rest)
93 :     in
94 :     init outList;
95 :     XDebug.xspawn ("Router", loop);
96 :     Router {reqch = routeReqCh, replych = routeReplyCh}
97 :     end
98 :    
99 :     fun addChild (Router{reqch,...}) arg = send (reqch, AddChild arg)
100 :     fun delChild (Router{reqch,...}) arg = send (reqch, DelChild arg)
101 :     fun getChildEnv (Router{reqch, replych}) arg = (
102 :     send (reqch, GetChild arg);
103 :     case recv replych of
104 :     NONE => raise NotFound
105 :     | SOME e => e
106 :     )
107 :    
108 :     (* Simple router for a composite widget with a single child.
109 :     *)
110 :     fun routePair (InEnv{m, k, ci,...}, parentOut, childOut) = let
111 :    
112 :     fun mEvt (OutEnv {m,...}) = m
113 :     fun kEvt (OutEnv {k,...}) = k
114 :     fun ciEvt (OutEnv {ci,...}) = ci
115 :    
116 :     fun handleEvt proj msg =
117 :     case stripMsg msg of
118 :     Here _ => sync (proj parentOut msg)
119 :     | ToChild msg' => sync (proj childOut msg')
120 :    
121 :     fun loop () =
122 :     loop (sync(choose[
123 :     wrap (m, handleEvt mEvt),
124 :     wrap (k, handleEvt kEvt),
125 :     wrap (ci, handleEvt ciEvt)
126 :     ]))
127 :    
128 :     in
129 :     XDebug.xspawn ("Router2", loop);
130 :     ()
131 :     end
132 :    
133 :     end (* Router *)
134 :    

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0