Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 171 lines (140 sloc) 5.06 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
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
80 let val_no_opacapi_check ?(side=`server) s =
81 StringMap.find s !(get_rmap side)
82
fccc685 Initial open-source release
MLstate authored
83 let val_noerr ?(side=`server) s =
84 opacapi_check s ;
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
85 val_no_opacapi_check ~side s
fccc685 Initial open-source release
MLstate authored
86
87 let pp_stringmap f map =
88 StringMap.iter
89 (fun k _v ->
90 Format.fprintf f "%S " k)
91 map
92
93 let val_ ?(side=`server) s =
94 try val_noerr ~side s
95 with Not_found ->
96 OManager.i_error
97 "OpaMapToIdent %s: Not found: %S\nIt contains:@\n%a@\n"
98 (print_side side) s
99 pp_stringmap
100 !(get_rmap side)
101
102 let typ s =
103 opacapi_check s ;
104 try StringMap.find s !r_type
105 with Not_found ->
106 OManager.i_error
107 "OpaMapToIdent: Type not found: %S\nIt contains:@\n%a@\n"
108 s
109 pp_stringmap
110 !r_type
111
112 let val_opt ?(side=`server) s =
113 opacapi_check s ;
114 StringMap.find_opt s !(get_rmap side)
115
116 let val_add ?(side=`server) s =
117 let new_s = Ident.next s in
118 let r_var = get_rmap side in
119 r_var := StringMap.safe_add s new_s !r_var;
120 new_s
121
122 let val_unsafe_add ?(side=`server) s =
123 let new_s = Ident.next s in
124 let r_var = get_rmap side in
125 r_var := StringMap.add s new_s !r_var;
126 new_s
127
128 let set_val_map ?(side=`server) v = (get_rmap side) := v
129
130 let set_typ_map v = r_type := v
131
132 let get_val_map ?(side=`server) () = !(get_rmap side)
133
134 let iter_val_map ?(side=`server) = fun f -> StringMap.iter f !(get_rmap side)
135
136 let map_val_map ?(side=`server) = fun f -> StringMap.map f !(get_rmap side)
137
138 let fold_val_map ?(side=(`server)) = fun f -> StringMap.fold f !(get_rmap side)
139
140 (* Special add and get for start_server value *)
141 let start_server = ref None
142 let str_start_server = "``"
143 let val_start_server () =
144 Option.map
145 (fun i -> val_ i)
146 !start_server
147
148 let val_start_server_add () =
149 match !start_server with
150 | Some _ -> failwith("start_server")
151 | None ->
152 let ident = Ident.next "run_services" in
153 start_server := (Some str_start_server);
154 set_val_map (StringMap.add str_start_server ident (get_val_map ()));
155 ident
156 (** Hack for opacapi - To be cleanned by introduce dependencies
157 beetween initialisations values (css, etc...) and init server *)
158 let _ = Opacapi.(!!) str_start_server
159
160 let get_toplevel_vars () = StringMap.elts !r_var
161
162 let filter f =
163 r_var := StringMap.filter_val f !r_var;
164 r_var_client := StringMap.filter_val f !r_var_client
165
166 let reset () =
167 set_val_map ~side:`server StringMap.empty;
168 set_val_map ~side:`client StringMap.empty;
169 set_typ_map StringMap.empty;
170 start_server := None
Something went wrong with that request. Please try again.