Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 168 lines (138 sloc) 4.983 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 (*
20 We test strictly than the val_ function is called only on
21 identifiers registred in opacapi, using the opacapi interface.
22 The physical test asserts than the string corresponding to the
23 identifier is not duplicated in the code containing the insertion.
24 *)
25 let opacapi_check s =
26 let is_in_opacapi =
27 try
28 let ss = Hashtbl.find Opacapi.table s in
29 s == ss
30 with
31 | Not_found -> false
32 in
33 if not is_in_opacapi
34 then (
35 #<If:OPACAPI_LOOSE>
36 ()
37 #<Else>
38 OManager.printf "OPACAPI violation, on ident %S@\n" s ;
39 OManager.printf "You should use opacapi for inserting identifiers from the stdlib@." ;
40 assert false
41 #<End>
42 )
43
44 (* ******************************************************************)
45 (* Side type and utils **********************************************)
46 (* ******************************************************************)
47 type side = [`client | `server]
48
49 let other_side = function
50 | `client -> `server
51 | `server -> `client
52
53 (* ******************************************************************)
54 (* Link name <-> ident **********************************************)
55 (* ******************************************************************)
56 (*
57 Two functions that is used to insert types or variables
58 Since everything is renamed with the surfaceAst, you cannot insert a
59 coercion to list in the AST (list is not going to be defined)
60 *)
61
62 (* Reference to the maps*)
63 let r_var = ref (StringMap.empty : Ident.t StringMap.t)
64 let r_var_client = ref (StringMap.empty : Ident.t StringMap.t)
65 let r_type = ref (StringMap.empty : Ident.t StringMap.t)
66
67 (* registering the references to be able to save them *)
68 let () =
69 PassTracker.register_global_ref r_var;
70 PassTracker.register_global_ref r_var_client;
71 PassTracker.register_global_ref r_type
72
73 let get_rmap = function
74 | `server -> r_var
75 | `client -> r_var_client
76 let print_side = function
77 | `server -> "server"
78 | `client -> "client"
79
80 let val_noerr ?(side=`server) s =
81 opacapi_check s ;
82 StringMap.find s !(get_rmap side)
83
84 let pp_stringmap f map =
85 StringMap.iter
86 (fun k _v ->
87 Format.fprintf f "%S " k)
88 map
89
90 let val_ ?(side=`server) s =
91 try val_noerr ~side s
92 with Not_found ->
93 OManager.i_error
94 "OpaMapToIdent %s: Not found: %S\nIt contains:@\n%a@\n"
95 (print_side side) s
96 pp_stringmap
97 !(get_rmap side)
98
99 let typ s =
100 opacapi_check s ;
101 try StringMap.find s !r_type
102 with Not_found ->
103 OManager.i_error
104 "OpaMapToIdent: Type not found: %S\nIt contains:@\n%a@\n"
105 s
106 pp_stringmap
107 !r_type
108
109 let val_opt ?(side=`server) s =
110 opacapi_check s ;
111 StringMap.find_opt s !(get_rmap side)
112
113 let val_add ?(side=`server) s =
114 let new_s = Ident.next s in
115 let r_var = get_rmap side in
116 r_var := StringMap.safe_add s new_s !r_var;
117 new_s
118
119 let val_unsafe_add ?(side=`server) s =
120 let new_s = Ident.next s in
121 let r_var = get_rmap side in
122 r_var := StringMap.add s new_s !r_var;
123 new_s
124
125 let set_val_map ?(side=`server) v = (get_rmap side) := v
126
127 let set_typ_map v = r_type := v
128
129 let get_val_map ?(side=`server) () = !(get_rmap side)
130
131 let iter_val_map ?(side=`server) = fun f -> StringMap.iter f !(get_rmap side)
132
133 let map_val_map ?(side=`server) = fun f -> StringMap.map f !(get_rmap side)
134
135 let fold_val_map ?(side=(`server)) = fun f -> StringMap.fold f !(get_rmap side)
136
137 (* Special add and get for start_server value *)
138 let start_server = ref None
139 let str_start_server = "``"
140 let val_start_server () =
141 Option.map
142 (fun i -> val_ i)
143 !start_server
144
145 let val_start_server_add () =
146 match !start_server with
147 | Some _ -> failwith("start_server")
148 | None ->
149 let ident = Ident.next "run_services" in
150 start_server := (Some str_start_server);
151 set_val_map (StringMap.add str_start_server ident (get_val_map ()));
152 ident
153 (** Hack for opacapi - To be cleanned by introduce dependencies
154 beetween initialisations values (css, etc...) and init server *)
155 let _ = Opacapi.(!!) str_start_server
156
157 let get_toplevel_vars () = StringMap.elts !r_var
158
159 let filter f =
160 r_var := StringMap.filter_val f !r_var;
161 r_var_client := StringMap.filter_val f !r_var_client
162
163 let reset () =
164 set_val_map ~side:`server StringMap.empty;
165 set_val_map ~side:`client StringMap.empty;
166 set_typ_map StringMap.empty;
167 start_server := None
Something went wrong with that request. Please try again.