1+ (*
2+ The MIT License (MIT)
3+
4+ Copyright (c) 2016 Maxime Ransan <[email protected] > 5+
6+ Permission is hereby granted, free of charge, to any person obtaining a copy
7+ of this software and associated documentation files (the "Software"), to deal
8+ in the Software without restriction, including without limitation the rights
9+ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10+ copies of the Software, and to permit persons to whom the Software is
11+ furnished to do so, subject to the following conditions:
12+
13+ The above copyright notice and this permission notice shall be included in all
14+ copies or substantial portions of the Software.
15+
16+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19+ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21+ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
22+ SOFTWARE.
23+
24+ *)
25+
126type constant =
227 | Constant_string of string
328 | Constant_bool of bool
429 | Constant_int of int
530 | Constant_float of float
631 | Constant_literal of string
732
33+ type option_name =
34+ | Simple_name of string
35+ | Extension_name of string
36+
837type message_literal = (string * value ) list
938and list_literal = value list
1039
@@ -13,19 +42,92 @@ and value =
1342 | Message_literal of message_literal
1443 | List_literal of list_literal
1544
16- type option_name = string
1745type t = option_name * value
1846type set = t list
1947
48+ let stringify_option_name = function
49+ | Simple_name s -> s
50+ | Extension_name s -> " (" ^ s ^ " )"
51+
52+ let option_name_equal a b =
53+ match a, b with
54+ | Simple_name a , Simple_name b -> String. equal a b
55+ | Extension_name a , Extension_name b -> String. equal a b
56+ | _ -> false
57+
2058let empty = []
21- let add t option_name value = (option_name, value) :: t
22- let merge t1 t2 = t2 @ t1
59+
60+ let rec merge_value v1 v2 =
61+ match v1, v2 with
62+ | Message_literal ml1 , Message_literal ml2 ->
63+ (* In this case, both the existing and new values are messages.
64+ Iterate through the fields of the new value.
65+ For each field, check if a field with the same name exists in the existing value.
66+ If it does and both field values are messages, merge them recursively.
67+ If it does not, add the new field to the existing message. *)
68+ let rec merge_lists list1 list2 =
69+ match list2 with
70+ | [] -> list1
71+ | (field , value ) :: rest ->
72+ let updated_list, is_merged =
73+ List. fold_left
74+ (fun (acc , merged ) (f , v ) ->
75+ if String. equal f field then (
76+ match value, v with
77+ | Message_literal _ , Message_literal _ ->
78+ ( acc @ [ f, merge_value value v ],
79+ true (* recursively merges two message literals *)
80+ | _ -> acc @ [ f, value ], merged
81+ ) else
82+ acc @ [ f, v ], merged)
83+ ([] , false ) list1
84+ in
85+ if is_merged then
86+ (* If the current field of list2 was found in list1 and the two
87+ values merged, continue with the rest of list2. The current field of
88+ list2 is not added to updated_list as its value has already been
89+ included during the merge. *)
90+ merge_lists updated_list rest
91+ else
92+ (* If the current field of list2 was not found in list1, add it to
93+ updated_list. *)
94+ merge_lists (updated_list @ [ field, value ]) rest
95+ in
96+ Message_literal (merge_lists ml1 ml2)
97+ | _ ->
98+ (* FIXME: This overrides the scalar value of an existing option with the
99+ scalar value of a new option, which is not allowed as per Protocol Buffer
100+ Language Specification. *)
101+ v2
102+
103+ let add option_set option_name value =
104+ match
105+ List. partition
106+ (fun ((name , _ ) : t ) -> option_name_equal name option_name)
107+ option_set
108+ with
109+ | [] , _ ->
110+ (* If the option does not currently exist in the set, add it *)
111+ (option_name, value) :: option_set
112+ | [ (_, existing_value) ], remainder ->
113+ (* If the option already exists in the set, merge it's value with the new value *)
114+ let merged_value = merge_value existing_value value in
115+ (option_name, merged_value) :: remainder
116+ | _ ->
117+ (* This is a sanity check. As we use an equality function, List.partition should
118+ * always partition the list into two lists where the first list has at most one element.
119+ * Hence, the condition that results in a call to failwith should never be satisfied. *)
120+ failwith
121+ " This should not happen, partition should result in at most single item \
122+ in left component"
23123
24124let get t option_name =
25- match List. assoc option_name t with
26- | c -> Some c
125+ match List. find ( fun ( other , _ ) -> option_name_equal option_name other) t with
126+ | _ , c -> Some c
27127 | exception Not_found -> None
28128
129+ let get_ext t option_name = get t (Extension_name option_name)
130+
29131let pp_constant ppf = function
30132 | Constant_string s -> Format. fprintf ppf " %S"
31133 | Constant_bool b -> Format. fprintf ppf " %B"
@@ -56,7 +158,9 @@ and pp_message_field ppf (field, value) =
56158 Format. fprintf ppf " %S: %a"
57159
58160let pp_t ppf (name , value ) =
59- Format. fprintf ppf " {@;<1 2>%S: %a@;<1 2>}"
161+ Format. fprintf ppf " {@;<1 2>%S: %a@;<1 2>}"
162+ (stringify_option_name name)
163+ pp_value value
60164
61165let pp_set ppf set =
62166 Format. fprintf ppf " [@[<v>%a@]]"
0 commit comments