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
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Florian Angeletti, projet Cambium, Inria Paris *)
(* *)
(* Copyright 2021 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Fold on a signature by syntactic group of items *)
(** Classes and class types generate ghosts signature items, we group them
together before printing *)
type sig_item =
{
src: Types.signature_item;
post_ghosts: Types.signature_item list
(** ghost classes types are post-declared *);
}
let flatten x = x.src :: x.post_ghosts
type core_rec_group =
| Not_rec of sig_item
| Rec_group of sig_item list
let rec_items = function
| Not_rec x -> [x]
| Rec_group x -> x
(** Private row types are manifested as a sequence of definitions
preceding a recursive group, we collect them and separate them from the
syntactic recursive group. *)
type rec_group =
{ pre_ghosts: Types.signature_item list; group:core_rec_group }
let next_group = function
| [] -> None
| src :: q ->
let ghosts, q =
match src with
| Types.Sig_class _ ->
(* a class declaration for [c] is followed by the ghost
declarations of class type [c], and type [c] *)
begin match q with
| ct::t::q -> [ct;t], q
| _ -> assert false
end
| Types.Sig_class_type _ ->
(* a class type declaration for [ct] is followed by the ghost
declaration of type [ct] *)
begin match q with
| t::q -> [t], q
| _ -> assert false
end
| Types.(Sig_module _ | Sig_value _ | Sig_type _ | Sig_typext _
| Sig_modtype _) ->
[],q
in
Some({src; post_ghosts=ghosts}, q)
let recursive_sigitem = function
| Types.Sig_type(ident, _, rs, _)
| Types.Sig_class(ident,_,rs,_)
| Types.Sig_class_type (ident,_,rs,_)
| Types.Sig_module(ident, _, _, rs, _) -> Some (ident,rs)
| Types.(Sig_value _ | Sig_modtype _ | Sig_typext _ ) -> None
let next x =
let cons_group pre group q =
let group = Rec_group (List.rev group) in
Some({ pre_ghosts=List.rev pre; group },q)
in
let rec not_in_group pre l = match next_group l with
| None ->
assert (pre=[]);
None
| Some(elt, q) ->
match recursive_sigitem elt.src with
| Some (id, _) when Btype.is_row_name (Ident.name id) ->
not_in_group (elt.src::pre) q
| None | Some (_, Types.Trec_not) ->
let sgroup = { pre_ghosts=List.rev pre; group=Not_rec elt } in
Some (sgroup,q)
| Some (id, Types.(Trec_first | Trec_next) ) ->
in_group ~pre ~ids:[id] ~group:[elt] q
and in_group ~pre ~ids ~group rem = match next_group rem with
| None -> cons_group pre group []
| Some (elt,next) ->
match recursive_sigitem elt.src with
| Some (id, Types.Trec_next) ->
in_group ~pre ~ids:(id::ids) ~group:(elt::group) next
| None | Some (_, Types.(Trec_not|Trec_first)) ->
cons_group pre group rem
in
not_in_group [] x
let seq l = Seq.unfold next l
let iter f l = Seq.iter f (seq l)
let fold f acc l = Seq.fold_left f acc (seq l)
let update_rec_next rs rem =
match rs with
| Types.Trec_next -> rem
| Types.(Trec_first | Trec_not) ->
match rem with
| Types.Sig_type (id, decl, Trec_next, priv) :: rem ->
Types.Sig_type (id, decl, rs, priv) :: rem
| Types.Sig_module (id, pres, mty, Trec_next, priv) :: rem ->
Types.Sig_module (id, pres, mty, rs, priv) :: rem
| _ -> rem
type in_place_patch = {
ghosts: Types.signature;
replace_by: Types.signature_item option;
}
let replace_in_place f sg =
let rec next_group f before signature =
match next signature with
| None -> None
| Some(item,sg) ->
core_group f ~before ~ghosts:item.pre_ghosts ~before_group:[]
(rec_items item.group) ~sg
and core_group f ~before ~ghosts ~before_group current ~sg =
let commit ghosts = before_group @ List.rev_append ghosts before in
match current with
| [] -> next_group f (commit ghosts) sg
| a :: q ->
match f ~ghosts a.src with
| Some (info, {ghosts; replace_by}) ->
let after = List.concat_map flatten q @ sg in
let after = match recursive_sigitem a.src, replace_by with
| None, _ | _, Some _ -> after
| Some (_,rs), None -> update_rec_next rs after
in
let before = match replace_by with
| None -> commit ghosts
| Some x -> x :: commit ghosts
in
let sg = List.rev_append before after in
Some(info, sg)
| None ->
let before_group =
List.rev_append a.post_ghosts (a.src :: before_group)
in
core_group f ~before ~ghosts ~before_group q ~sg
in
next_group f [] sg
|
