Source file environment.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
open UtilsLib
open Logic
open Interface
module type Environment_sig =
sig
exception Signature_not_found of string
exception Lexicon_not_found of string
exception Entry_not_found of string
module Signature1:Signature_sig with type term=Lambda.Lambda.term
module Lexicon:Interface.Lexicon_sig with type Signature.t=Signature1.t and type Signature.term=Signature1.term and type Signature.stype=Signature1.stype
type t
type entry =
| Signature of Signature1.t
| Lexicon of Lexicon.t
val empty : t
val insert : ?overwrite:bool -> entry -> to_be_dumped:bool -> t -> t
val get_signature : string -> t -> Signature1.t
val get_lexicon : string -> t -> Lexicon.t
val get : string -> t -> entry
val append : ?overwrite:bool -> t -> t -> t
val iter : (entry -> unit) -> t -> unit
val fold : (entry -> 'a -> 'a) -> 'a -> t -> 'a
val sig_number : t -> int
val lex_number : t -> int
val choose_signature : t -> Signature1.t option
val compatible_version : t -> bool
val read : string -> string list -> t option
val write : string -> t -> unit
val select : string -> t -> t
val unselect : t -> t
val focus : t -> entry option
end
module Lex=Acg_lexicon.Data_Lexicon
module Environment =
struct
module Lexicon=Lex
module Sg=Lex.Signature
module Signature1=Sg
exception Signature_not_found of string
exception Lexicon_not_found of string
exception Entry_not_found of string
module Env = Utils.StringMap
type to_be_dumped = bool
type entry =
| Signature of Sg.t
| Lexicon of Lex.t
module Dep =
DependencyManager.Make (
struct
type t = entry
let to_string = function
| Signature s -> fst (Sg.name s)
| Lexicon l -> fst (Lex.name l)
let compare e1 e2 =
String.compare (to_string e1) (to_string e2)
end)
type t = {map:(entry*to_be_dumped) Env.t;
sig_number:int;
lex_number:int;
focus:entry option;
version:string;
dependencies:Dep.t}
let empty = {map=Env.empty;
sig_number=0;
lex_number=0;
focus=None;
version=Version.version;
dependencies=Dep.empty}
let check_version e =
let v=e.version in
if (v <> Version.version) then
raise (Error.Error (Error.Version_error (Error.Outdated_version (v,Version.version))))
else
()
let append ?(overwrite=false) e1 e2 =
let () = check_version e1 in
let () = check_version e2 in
let erased_sig = ref 0 in
let erased_lex = ref 0 in
let new_map =
Env.merge
(fun k v1 v2 ->
match v1,v2,overwrite with
| None,None,_ -> None
| None,Some v,_ -> Some v
| Some v,None,_ -> Some v
| Some (Lexicon _,_),Some v2,true ->
let () = erased_lex:=!erased_lex+1 in
Some v2
| Some (Signature _,_),Some v2,true ->
let () = erased_sig:=!erased_sig+1 in
Some v2
| Some (_,_),Some (v2,_),false ->
match v2 with
| Signature sg ->
let _,pos=Sg.name sg in
raise (Error.Error (Error.Env_error (Error.Duplicated_entry k,pos)))
| Lexicon lex ->
let _,pos=Lex.name lex in
raise (Error.Error (Error.Env_error (Error.Duplicated_entry k,pos))))
e1.map
e2.map in
{map=new_map;
sig_number=e1.sig_number + e2.sig_number - !erased_sig;
lex_number=e1.lex_number + e2.lex_number - !erased_lex;
focus = (match e2.focus with
| Some e -> Some e
| None -> e1.focus);
version=Version.version;
dependencies=Dep.merge e1.dependencies e2.dependencies}
let update_dependencies lex m =
match Lex.get_dependencies lex with
| Lex.Signatures (s1,s2) ->
Dep.add_dependency
(Lexicon lex)
(Signature s1)
(Dep.add_dependency (Lexicon lex) (Signature s2) m)
| Lex.Lexicons (l1,l2) ->
Dep.add_dependency
(Lexicon lex)
(Lexicon l1)
(Dep.add_dependency (Lexicon lex) (Lexicon l2) m)
let insert ?(overwrite=false) d ~to_be_dumped:dump e =
match d with
| Signature s ->
let name,(p1,p2) = Sg.name s in
if (not (Env.mem name e.map))||overwrite
then
{e with
map=Env.add name (d,dump) e.map ;
sig_number=e.sig_number+1}
else
raise (Error.Error (Error.Env_error (Error.Duplicated_signature name,(p1,p2))))
| Lexicon l ->
let name,(p1,p2) = Lex.name l in
if not (Env.mem name e.map)||overwrite
then
{e with
map=Env.add name (d,dump) e.map ;
lex_number=e.lex_number+1;
dependencies = update_dependencies l e.dependencies}
else
raise (Error.Error (Error.Env_error (Error.Duplicated_lexicon name,(p1,p2))))
let iter f {map=e;_} = Env.iter (fun _ (d,_) -> f d) e
let fold f a {map=e;_} = Env.fold (fun _ (d,_) acc -> f d acc) e a
let sig_number {sig_number=n;_} = n
let lex_number {lex_number=n;_} = n
let get_signature s {map=e;_} =
match Env.find s e with
| Signature sg,_ -> sg
| Lexicon _,_ -> raise (Signature_not_found s)
| exception Not_found -> raise (Signature_not_found s)
let get_lexicon s {map=e;_} =
match Env.find s e with
| Signature _,_ -> raise (Lexicon_not_found s)
| Lexicon lex,_ -> lex
| exception Not_found -> raise (Lexicon_not_found s)
let get s {map=e;_} =
try
let data,_ = Env.find s e in
data
with
| Not_found -> raise (Entry_not_found s)
let compatible_version {version;_} = version = Version.version
let stamp v = Printf.sprintf "acg object file version %s" v
let read filename dirs =
try
let file =(Utils.find_file filename dirs) in
let in_ch = open_in file in
let first_line = input_line in_ch in
if first_line = (stamp Version.version) then
let () = Printf.printf "Loading object file \"%s\"...\n%!" file in
let new_env = input_value in_ch in
let () = Printf.printf "Done.\n%!" in
let () = close_in in_ch in
Some new_env
else
let object_version = Scanf.sscanf first_line "acg object file version %s" (fun s -> s) in
let err = Error.Version_error (Error.Outdated_version (object_version,Version.version)) in
let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg err filename) in
None
with
| Scanf.Scan_failure _ ->
let err = Error.System_error (Printf.sprintf "\"%s\" is not recognized as an acg object file" filename )in
let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg err filename) in
None
| Utils.No_file(_,msg) ->
let err = Error.System_error (Printf.sprintf "No such file \"%s\" in %s" filename msg) in
let () = Printf.fprintf stderr "Error: %s\n%!" (Error.error_msg err filename) in
None
let write filename env =
let () = Logs.debug (fun m -> m "The environment currently has %d signature(s) and %d lexicon(s)." (sig_number env) (lex_number env)) in
let new_env =
Env.fold
(fun _ (d,dump) acc ->
if dump then
insert d ~to_be_dumped:false acc
else
acc)
env.map
empty in
let out_ch=open_out filename in
let () = Printf.fprintf out_ch "%s\n" (stamp Version.version) in
let () = output_value out_ch {new_env with dependencies=env.dependencies} in
close_out out_ch
let select name e =
{e with focus=Some (get name e)}
let unselect e = {e with focus=None}
let focus {focus=f;_} = f
exception Sig of Sg.t
let choose_signature {map=e;_} =
try
let () = Env.fold
(fun _ c a ->
match c with
| Signature s,_ -> raise (Sig s)
| Lexicon _,_ -> a )
e
() in
None
with
| Sig s -> Some s
end