Source file `atd_annot.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


open Printf

type t = Atd_ast.annot

let error_at loc s =
  failwith (sprintf "%s:\n%s" (Atd_ast.string_of_loc loc) s)

let has_section k l =
  try ignore (List.assoc k l); true
  with Not_found -> false

let has_field k k2 l =
  List.exists (
    fun k1 ->
      try
        (* each section must be unique *)
        let _, l2 = List.assoc k1 l in
        ignore (List.assoc k2 l2);
        true
      with Not_found -> false
  ) k

let rec find f = function
    [] -> None
  | x :: l ->
      match f x with
          None -> find f l
        | Some _ as y -> y

let get_flag k k2 l =
  let result =
    find (
      fun k1 ->
        try
          (* each section must be unique *)
          let loc, l2 = List.assoc k1 l in
          let loc, o = List.assoc k2 l2 in
          match o with
              None -> Some true
            | Some "true" -> Some true
            | Some "false" -> Some false
            | Some s ->
                error_at loc
                  (sprintf "Invalid value %S for flag %s.%s" s k1 k2)
        with Not_found -> None
    ) k
  in
  match result with
      None -> false
    | Some x -> x

let get_field parse default k k2 l =
  let result =
    find (
      fun k1 ->
        try
          (* each section must be unique *)
          let loc, l2 = List.assoc k1 l in
          let loc, o = List.assoc k2 l2 in
          match o with
              Some s ->
                (match parse s with
                     Some x as y -> y
                   | None ->
                       error_at loc
                         (sprintf "Invalid annotation <%s %s=%S>" k1 k2 s)
                )
            | None ->
                error_at loc
                  (sprintf "Missing value for annotation %s.%s" k1 k2)
        with Not_found ->
          None
    ) k
  in
  match result with
      None -> default
    | Some x -> x

(* replace first occurrence, if any *)
let rec replace k v = function
    (k', _) as x :: l ->
      if k = k' then
        (k, v) :: l
      else
        x :: replace k v l
  | [] ->
      []

let set_field loc k k2 v l : Atd_ast.annot =
  try
    let section_loc, section = List.assoc k l in
    let section =
      try
        let _field = List.assoc k2 section in
        replace k2 (loc, v) section
      with Not_found ->
        (k2, (loc, v)) :: section
    in
    replace k (section_loc, section) l

  with Not_found ->
    (k, (loc, [ k2, (loc, v) ])) :: l


let collapse merge l =
  let tbl = Hashtbl.create 10 in
  let n = ref 0 in

  List.iter (
    fun (s1, f1) ->
      incr n;
      try
        let _, f2 = Hashtbl.find tbl s1 in
        Hashtbl.replace tbl s1 (!n, merge f1 f2)
      with Not_found ->
        Hashtbl.add tbl s1 (!n, f1)
  ) (List.rev l);

  let l = Hashtbl.fold (fun s (i, f) l -> (i, (s, f)) :: l) tbl [] in
  let l = List.sort (fun (i, _) (j, _) -> compare j i) l in
  List.map snd l

let override_values x1 x2 = x1

let override_fields (loc1, l1) (loc2, l2) =
  (loc1, collapse override_values (l1 @ l2))

let merge l =
  collapse override_fields l

let create_id =
  let n = ref (-1) in
  fun () ->
    incr n;
    if !n < 0 then
      failwith "Atd_annot.create_id: counter overflow"
    else
      string_of_int !n