1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*                       Pierre Chambart, OCamlPro                        *)
6(*           Mark Shinwell and Leo White, Jane Street Europe              *)
7(*                                                                        *)
8(*   Copyright 2013--2016 OCamlPro SAS                                    *)
9(*   Copyright 2014--2016 Jane Street Group LLC                           *)
10(*                                                                        *)
11(*   All rights reserved.  This file is distributed under the terms of    *)
12(*   the GNU Lesser General Public License version 2.1, with the          *)
13(*   special exception on linking described in the file LICENSE.          *)
14(*                                                                        *)
15(**************************************************************************)
16
17[@@@ocaml.warning "+a-4-9-30-40-41-42"]
18
19module type BaseId = sig
20  type t
21  val equal : t -> t -> bool
22  val compare : t -> t -> int
23  val hash : t -> int
24  val name : t -> string option
25  val to_string : t -> string
26  val output : out_channel -> t -> unit
27  val print : Format.formatter -> t -> unit
28end
29
30module type Id = sig
31  include BaseId
32  val create : ?name:string -> unit -> t
33end
34
35module type UnitId = sig
36  module Compilation_unit : Identifiable.Thing
37  include BaseId
38  val create : ?name:string -> Compilation_unit.t -> t
39  val unit : t -> Compilation_unit.t
40end
41
42module Id(E:sig end) : Id = struct
43  type t = int * string
44  let empty_string = ""
45  let create = let r = ref 0 in
46    fun  ?(name=empty_string) () -> incr r; !r, name
47  let equal (t1,_) (t2,_) = (t1:int) = t2
48  let compare (t1,_) (t2,_) = t1 - t2
49  let hash (t,_) = t
50  let name (_,name) =
51    if name == empty_string
52    then None
53    else Some name
54  let to_string (t,name) =
55    if name == empty_string
56    then string_of_int t
57    else Printf.sprintf "%s_%i" name t
58  let output fd t = output_string fd (to_string t)
59  let print ppf v = Format.pp_print_string ppf (to_string v)
60end
61
62module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) :
63  UnitId with module Compilation_unit := Compilation_unit = struct
64  type t = {
65    id : Innerid.t;
66    unit : Compilation_unit.t;
67  }
68  let compare x y =
69    let c = Innerid.compare x.id y.id in
70    if c <> 0
71    then c
72    else Compilation_unit.compare x.unit y.unit
73  let output oc x =
74    Printf.fprintf oc "%a.%a"
75      Compilation_unit.output x.unit
76      Innerid.output x.id
77  let print ppf x =
78    Format.fprintf ppf "%a.%a"
79      Compilation_unit.print x.unit
80      Innerid.print x.id
81  let hash off = Hashtbl.hash off
82  let equal o1 o2 = compare o1 o2 = 0
83  let name o = Innerid.name o.id
84  let to_string x =
85    Format.asprintf "%a.%a"
86      Compilation_unit.print x.unit
87      Innerid.print x.id
88  let create ?name unit =
89    let id = Innerid.create ?name () in
90    { id; unit }
91  let unit x = x.unit
92end
93