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
open Bwd
open Bwd.Infix
open ExplicatorSigs
type 'tag block =
{ begin_line_num : int
; end_line_num : int
; tagged_positions : ('tag option * Range.position) list
; tagged_lines : ('tag * int) list}
type 'tag t = (Range.source * 'tag block list) list
let dump_block dump_tag fmt {begin_line_num; end_line_num; tagged_positions; tagged_lines} =
Format.fprintf fmt {|@[<1>{begin_line_num=%d;@ end_line_num=%d;@ @[<2>tagged_positions=@ @[%a@]@];@ @[<2>tagged_lines=@,@[%a@]@]}@]|}
begin_line_num end_line_num
(Utils.dump_list (Utils.dump_pair (Utils.dump_option dump_tag) Range.dump_position)) tagged_positions
(Utils.dump_list (Utils.dump_pair dump_tag Format.pp_print_int)) tagged_lines
let dump dump_tag =
Utils.dump_list @@ Utils.dump_pair Range.dump_source (Utils.dump_list (dump_block dump_tag))
module Make (Tag : Tag) =
struct
type unflattened_block =
{ begin_line_num : int
; end_line_num : int
; ranges : (Tag.t * Range.t) list}
module Splitter :
sig
val partition : block_splitting_threshold:int -> (Tag.t * Range.t) list -> unflattened_block list
end
=
struct
let compare_range (s1 : Range.t) (s2 : Range.t) =
Utils.compare_pair Int.compare Int.compare
(Range.end_offset s1, Range.begin_offset s1)
(Range.end_offset s2, Range.begin_offset s2)
let compare_range_tagged (t1, sp1) (t2, sp2) =
Utils.compare_pair compare_range Int.compare
(sp1, Tag.priority t1)
(sp2, Tag.priority t2)
let sort_tagged = List.stable_sort compare_range_tagged
let block_of_range ((_, sloc) as s) : unflattened_block =
{ begin_line_num = Range.begin_line_num sloc
; end_line_num = Range.end_line_num sloc
; ranges = [s]}
let partition_sorted ~block_splitting_threshold l : unflattened_block list =
let rec go rs block (blocks : unflattened_block list) =
match rs with
| Emp -> block :: blocks
| Snoc (rs, ((_, rloc) as r)) ->
if block.begin_line_num - Range.end_line_num rloc > block_splitting_threshold then
go rs (block_of_range r) (block :: blocks)
else
let begin_line_num = Int.min block.begin_line_num (Range.begin_line_num rloc) in
go rs {block with begin_line_num; ranges = r :: block.ranges} blocks
in
match Bwd.of_list l with
| Emp -> []
| Snoc (rs, r) ->
go rs (block_of_range r) []
let partition ~block_splitting_threshold l =
partition_sorted ~block_splitting_threshold (sort_tagged l)
end
module BlockFlattener :
sig
val flatten : blend:(Tag.t -> Tag.t -> Tag.t) -> (Tag.t * Range.t) list -> (Tag.t option * Range.position) list
end
=
struct
type t = (Tag.t option * Range.position) bwd
let impose ~blend xtag (x1 : Range.position) (x2 : Range.position) : t -> t =
let blend_opt =
function
| None -> Some xtag
| Some t -> Some (blend t xtag)
in
let[@tail_mod_cons] rec go2 : t -> t =
function
| Snoc (ps, (ptag, ploc)) when ploc.offset >= x1.offset ->
Snoc (go2 ps, (blend_opt ptag, ploc))
| ps -> ps
in
let[@tail_mod_cons] rec go1 : t -> t =
function
| Snoc (ps, ((_, ploc) as p)) when ploc.offset >= x2.offset ->
Snoc (go1 ps, p)
| ps -> go2 ps
in
go1
let ensure_point (x : Range.position) =
let[@tail_mod_cons] rec go : t -> t =
function
| Snoc (ps, ((_, ploc) as p)) when ploc.offset > x.offset ->
Snoc (go ps, p)
| Emp -> Emp <: (None, x)
| Snoc (_, (ptag, p)) as ps ->
if p.offset = x.offset then
ps
else
ps <: (ptag, x)
in
go
let add ~blend l (tag, value) =
let x1, x2 = Range.split value in
impose ~blend tag x1 x2 @@ ensure_point x2 @@ ensure_point x1 l
let flatten ~blend l =
Bwd.to_list @@ List.fold_left (add ~blend) Emp l
end
module File :
sig
val flatten : block_splitting_threshold:int -> blend:(Tag.t -> Tag.t -> Tag.t) -> (Tag.t * Range.t) list -> Tag.t block list
end
=
struct
let flatten_block ~blend ({begin_line_num; end_line_num; ranges} : unflattened_block) =
{ begin_line_num
; end_line_num
; tagged_positions = BlockFlattener.flatten ~blend ranges
; tagged_lines = List.map (fun (tag, value) -> tag, Range.end_line_num value) ranges
}
let flatten ~block_splitting_threshold ~blend rs =
List.map (flatten_block ~blend) @@ Splitter.partition ~block_splitting_threshold rs
end
module Files :
sig
val flatten : block_splitting_threshold:int -> blend:(Tag.t -> Tag.t -> Tag.t) -> (Tag.t * Range.t) list -> (Range.source * Tag.t block list) list
end
=
struct
module FileMap = Map.Make(struct
type t = Range.source
let compare : t -> t -> int = Stdlib.compare
end)
let add m data =
m |>
FileMap.update (Range.source (snd data)) @@ function
| None -> Some (Emp <: data)
| Some rs -> Some (rs <: data)
let priority l : int = List.fold_left (fun p (tag, _) -> Int.min p (Tag.priority tag)) Int.max_int l
let compare_part (p1 : Range.source * int * Tag.t block list) (p2 : Range.source * int * Tag.t block list) =
match p1, p2 with
| (_, pri1, _), (_, pri2, _) when pri1 <> pri2 -> Int.compare pri1 pri2
| (s1, _, _), (s2, _, _) -> Option.compare String.compare (Range.title s1) (Range.title s2)
let flatten ~block_splitting_threshold ~blend rs =
rs
|> List.fold_left add FileMap.empty
|> FileMap.bindings
|> List.map (fun (src, rs) -> let rs = Bwd.to_list rs in src, priority rs, File.flatten ~block_splitting_threshold ~blend rs)
|> List.filter (fun (_, _, l) -> l <> [])
|> List.stable_sort compare_part
|> List.map (fun (src, _, part) -> src, part)
end
let flatten = Files.flatten
end