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
open Ppxlib
let loc = Location.none
type cell =
{ rule : Rule.t ;
mutable higher : cell list ;
mutable level : int }
let make_cell ?(level=(-1)) ?(higher=[]) rule =
{ rule ; higher ; level }
let identity =
let name = "'a -> 'a" in
let matcher (itype, otype) =
if Parsetree_utils.equal_core_type itype otype
then Some []
else None
in
let builder casts =
assert (casts = []);
[%expr fun x -> x]
in
make_cell (Rule.make ~name ~matcher ~builder ())
module SMap = Map.Make(String)
let cells : cell SMap.t ref = ref (SMap.singleton (Rule.name_ identity.rule) identity)
let lookup_cell rule =
SMap.find (Rule.name_ rule) !cells
let lookup name =
(SMap.find name !cells).rule
let register ?(applies_before=[]) ?(applies_after=[]) rule =
let cell = make_cell ~higher:(List.map lookup_cell applies_before) rule in
cells := SMap.add (Rule.name_ rule) cell !cells;
identity.higher <- cell :: identity.higher;
List.iter
(fun rule' ->
let cell' = lookup_cell rule' in
cell'.higher <- cell :: cell'.higher)
applies_after
let fill_levels () =
let rec fill_level i lower cell =
assert (not (List.mem cell lower));
if cell.level < i then
cell.level <- i;
List.iter (fill_level (i+1) (cell :: lower)) cell.higher
in
SMap.iter (fun _ cell -> cell.level <- -1) !cells;
fill_level 0 [] identity
let fold_by_priority f x =
let rec fold x level = function
| [] -> x
| cells_at_that_level ->
let x' = f (List.map (fun cell -> cell.rule) cells_at_that_level) x in
let next_level = level + 1 in
let cells_at_next_level =
List.map (fun cell -> cell.higher) cells_at_that_level
|> List.flatten
|> List.filter (fun cell -> cell.level = next_level)
in
fold x' next_level cells_at_next_level
in
fill_levels ();
fold x identity.level [identity]