Skip to content

Commit 7521196

Browse files
azzsalazzsal
authored
Abstract away Sig_item_map module (#98)
* Add initial implementation of Sig_item_map module * Change internal representation of sig_item_map to a record * Add initial implementation of the diff function * Update diff function * Add a parametrized type alias for diff_item * Refactor Sig_item_map module * Add change log entry * Remove unnecessary change log entry
1 parent 2cb00d4 commit 7521196

File tree

3 files changed

+115
-52
lines changed

3 files changed

+115
-52
lines changed

‎lib/diff.ml‎

Lines changed: 33 additions & 52 deletions
Original file line numberDiff line numberDiff line change
@@ -35,31 +35,21 @@ and sig_item =
3535
| Type of type_
3636
| Modtype of modtype
3737

38-
type item_type = Value_item | Module_item | Type_item | Modtype_item
39-
[@@deriving ord]
40-
41-
type sig_items =
42-
| Val of value_description
43-
| Mod of module_declaration
44-
| Typ of type_declaration * Ident.t
45-
| Modtype of modtype_declaration
46-
47-
module Sig_item_map = Map.Make (struct
48-
type t = item_type * string [@@deriving ord]
49-
end)
50-
5138
let extract_items items =
5239
List.fold_left
5340
(fun tbl item ->
5441
match item with
5542
| Sig_module (id, _, mod_decl, _, _) ->
56-
Sig_item_map.add (Module_item, Ident.name id) (Mod mod_decl) tbl
43+
Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Module mod_decl
44+
tbl
5745
| Sig_modtype (id, mtd_decl, _) ->
58-
Sig_item_map.add (Modtype_item, Ident.name id) (Modtype mtd_decl) tbl
46+
Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Modtype mtd_decl
47+
tbl
5948
| Sig_value (id, val_des, _) ->
60-
Sig_item_map.add (Value_item, Ident.name id) (Val val_des) tbl
49+
Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Value val_des tbl
6150
| Sig_type (id, type_decl, _, _) ->
62-
Sig_item_map.add (Type_item, Ident.name id) (Typ (type_decl, id)) tbl
51+
Sig_item_map.add ~name:(Ident.name id) Sig_item_map.Type
52+
(type_decl, id) tbl
6353
| _ -> tbl)
6454
Sig_item_map.empty items
6555

@@ -79,11 +69,11 @@ let module_type_fallback ~loc ~typing_env ~name ~reference ~current =
7969
let type_item ~typing_env ~name ~reference ~current =
8070
match (reference, current) with
8171
| None, None -> None
82-
| Some (Typ (reference, _)), None ->
72+
| Some (reference, _), None ->
8373
Some (Type { tname = name; tdiff = Removed reference })
84-
| None, Some (Typ (current, _)) ->
74+
| None, Some (current, _) ->
8575
Some (Type { tname = name; tdiff = Added current })
86-
| Some (Typ (reference, refId)), Some (Typ (current, curId)) -> (
76+
| Some (reference, refId), Some (current, curId) -> (
8777
let type_coercion1 () =
8878
Includecore.type_declarations ~loc:current.type_loc typing_env
8979
~mark:false name current (Pident curId) reference
@@ -96,16 +86,14 @@ let type_item ~typing_env ~name ~reference ~current =
9686
| None, None -> None
9787
| _, _ ->
9888
Some (Type { tname = name; tdiff = Modified { reference; current } }))
99-
| _ -> None
10089

10190
let value_item ~typing_env ~name ~reference ~current =
10291
match (reference, current) with
10392
| None, None -> None
104-
| Some (Val reference), None ->
93+
| Some reference, None ->
10594
Some (Value { vname = name; vdiff = Removed reference })
106-
| None, Some (Val current) ->
107-
Some (Value { vname = name; vdiff = Added current })
108-
| Some (Val reference), Some (Val current) -> (
95+
| None, Some current -> Some (Value { vname = name; vdiff = Added current })
96+
| Some reference, Some current -> (
10997
let val_coercion1 () =
11098
Includecore.value_descriptions ~loc:current.val_loc typing_env name
11199
current reference
@@ -121,47 +109,40 @@ let value_item ~typing_env ~name ~reference ~current =
121109
| exception Includecore.Dont_match _ ->
122110
Some (Value { vname = name; vdiff = Modified { reference; current } })
123111
)
124-
| _ -> None
125112

126113
let rec items ~reference ~current =
127114
let env = Typing_env.for_diff ~reference ~current in
128115
let ref_items = extract_items reference in
129116
let curr_items = extract_items current in
130-
Sig_item_map.merge
131-
(fun (item_type, name) ref_opt curr_opt ->
132-
match (item_type, ref_opt, curr_opt) with
133-
| Value_item, reference, current ->
134-
value_item ~typing_env:env ~name ~reference ~current
135-
| Module_item, reference, current ->
136-
module_item ~typing_env:env ~name ~reference ~current
137-
| Type_item, reference, current ->
138-
type_item ~typing_env:env ~name ~reference ~current
139-
| Modtype_item, reference, current ->
140-
module_type_item ~typing_env:env ~name ~reference ~current)
141-
ref_items curr_items
142-
|> Sig_item_map.bindings |> List.map snd
143-
144-
and module_item ~typing_env ~name ~reference ~current =
117+
let diff_item : type a. (a, 'diff) Sig_item_map.diff_item =
118+
fun item_type name reference current ->
119+
match item_type with
120+
| Value -> value_item ~typing_env:env ~name ~reference ~current
121+
| Module -> module_item ~typing_env:env ~name ~reference ~current
122+
| Modtype -> module_type_item ~typing_env:env ~name ~reference ~current
123+
| Type -> type_item ~typing_env:env ~name ~reference ~current
124+
in
125+
Sig_item_map.diff ~diff_item:{ diff_item } ref_items curr_items
126+
127+
and module_item ~typing_env ~name ~(reference : module_declaration option)
128+
~(current : module_declaration option) =
145129
match (reference, current) with
146130
| None, None -> None
147-
| None, Some (Mod curr_md) ->
148-
Some (Module { mname = name; mdiff = Added curr_md })
149-
| Some (Mod ref_md), None ->
150-
Some (Module { mname = name; mdiff = Removed ref_md })
151-
| Some (Mod reference), Some (Mod current) ->
131+
| None, Some curr_md -> Some (Module { mname = name; mdiff = Added curr_md })
132+
| Some ref_md, None -> Some (Module { mname = name; mdiff = Removed ref_md })
133+
| Some reference, Some current ->
152134
module_declaration ~typing_env ~name ~reference ~current
153-
| _ -> assert false
154135

155-
and module_type_item ~typing_env ~name ~reference ~current =
136+
and module_type_item ~typing_env ~name ~(reference : modtype_declaration option)
137+
~(current : modtype_declaration option) =
156138
match (reference, current) with
157139
| None, None -> None
158-
| None, Some (Modtype curr_mtd) ->
140+
| None, Some curr_mtd ->
159141
Some (Modtype { mtname = name; mtdiff = Added curr_mtd })
160-
| Some (Modtype ref_mtd), None ->
142+
| Some ref_mtd, None ->
161143
Some (Modtype { mtname = name; mtdiff = Removed ref_mtd })
162-
| Some (Modtype ref_mtd), Some (Modtype curr_mtd) ->
144+
| Some ref_mtd, Some curr_mtd ->
163145
modtype_declaration ~typing_env ~name ~reference:ref_mtd ~current:curr_mtd
164-
| _ -> assert false
165146

166147
and module_declaration ~typing_env ~name ~reference ~current =
167148
module_type ~typing_env ~name ~ref_module_type:reference.md_type

‎lib/sig_item_map.ml‎

Lines changed: 63 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,63 @@
1+
open Types
2+
3+
type t = {
4+
values_map : value_description String_map.t;
5+
modules_map : module_declaration String_map.t;
6+
modtypes_map : modtype_declaration String_map.t;
7+
types_map : (type_declaration * Ident.t) String_map.t;
8+
}
9+
10+
type _ item_type =
11+
| Value : value_description item_type
12+
| Module : module_declaration item_type
13+
| Modtype : modtype_declaration item_type
14+
| Type : (type_declaration * Ident.t) item_type
15+
16+
let empty : t =
17+
{
18+
values_map = String_map.empty;
19+
modules_map = String_map.empty;
20+
modtypes_map = String_map.empty;
21+
types_map = String_map.empty;
22+
}
23+
24+
let add (type a) ~name (item_type : a item_type) (item : a) maps : t =
25+
match item_type with
26+
| Value -> { maps with values_map = String_map.add name item maps.values_map }
27+
| Module ->
28+
{ maps with modules_map = String_map.add name item maps.modules_map }
29+
| Modtype ->
30+
{ maps with modtypes_map = String_map.add name item maps.modtypes_map }
31+
| Type -> { maps with types_map = String_map.add name item maps.types_map }
32+
33+
type ('a, 'diff) diff_item =
34+
'a item_type -> string -> 'a option -> 'a option -> 'diff option
35+
36+
type 'diff poly_diff_item = { diff_item : 'a. ('a, 'diff) diff_item }
37+
38+
let diff ~diff_item:{ diff_item } ref_maps curr_maps : 'diff list =
39+
let value_diffs =
40+
String_map.merge
41+
(fun name ref_opt curr_opt -> diff_item Value name ref_opt curr_opt)
42+
ref_maps.values_map curr_maps.values_map
43+
|> String_map.bindings |> List.map snd
44+
in
45+
let module_diffs =
46+
String_map.merge
47+
(fun name ref_opt curr_opt -> diff_item Module name ref_opt curr_opt)
48+
ref_maps.modules_map curr_maps.modules_map
49+
|> String_map.bindings |> List.map snd
50+
in
51+
let modtype_diffs =
52+
String_map.merge
53+
(fun name ref_opt curr_opt -> diff_item Modtype name ref_opt curr_opt)
54+
ref_maps.modtypes_map curr_maps.modtypes_map
55+
|> String_map.bindings |> List.map snd
56+
in
57+
let type_diffs =
58+
String_map.merge
59+
(fun name ref_opt curr_opt -> diff_item Type name ref_opt curr_opt)
60+
ref_maps.types_map curr_maps.types_map
61+
|> String_map.bindings |> List.map snd
62+
in
63+
value_diffs @ module_diffs @ modtype_diffs @ type_diffs

‎lib/sig_item_map.mli‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
open Types
2+
3+
type t
4+
5+
type _ item_type =
6+
| Value : value_description item_type
7+
| Module : module_declaration item_type
8+
| Modtype : modtype_declaration item_type
9+
| Type : (type_declaration * Ident.t) item_type
10+
11+
val empty : t
12+
val add : name:string -> 'a item_type -> 'a -> t -> t
13+
14+
type ('a, 'diff) diff_item =
15+
'a item_type -> string -> 'a option -> 'a option -> 'diff option
16+
17+
type 'diff poly_diff_item = { diff_item : 'a. ('a, 'diff) diff_item }
18+
19+
val diff : diff_item:'diff poly_diff_item -> t -> t -> 'diff list

0 commit comments

Comments
 (0)