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

(* Pa_qualified
   -----------------------------------------------------------------------------
   Copyright (C) 2015, Max Mouratov

   License:
     This library is free software; you can redistribute it and/or
     modify it under the terms of the GNU Library General Public
     License version 2.1, as published by the Free Software Foundation.

     This library is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

     See the GNU Library General Public License version 2.1 for more details
     (enclosed in LICENSE.txt).

   Description:
     Pa_qualified adds support for fully qualified module references to OCaml.
     If a module reference (in any possible context) starts with "Q.", then
     the rest of the reference denotes a context-independent globally unique
     path (as if the reference was located at the very beginning of the file).
     Qualified references can never be shadowed by other definitions
     (warranty void if "Q" is defined explicitly somewhere).

     See README.rst for more information.
*)


open Camlp4


module StringSet = Set.Make (String)

module Id: Sig.Id = struct
  let name = "pa_qualified"
  let version = "0.5"
end


(* The predefined prefix that denotes a globally qualified name *)
let qualified_prefix = "Q"


module Make (AstFilters: Camlp4.Sig.AstFilters) =
struct
  open AstFilters


  (* Generating a globally unique name for the helper module *)
  let gen_helper_name loc =
    let fname = Filename.chop_extension (Ast.Loc.file_name loc) in
    Printf.sprintf "_Q_%s_" fname


  (* Replacing all Qs with the unique name of the helper module,
     as well as collecting all the different Xs in Q.X.* references *)
  let make_reference_collector helper_name =
    object (self) inherit Ast.map as super

      (* A set of globally referenced modules *)
      val mutable collected = StringSet.empty
      method get_collected =
        StringSet.elements collected

      method ident id =
        match id with

          (* Getting the X out of Q.X.*,
             replacing Q with a reference to the helper module *)
          | IdAcc _ ->
              (match Ast.list_of_ident id [] with
                | IdUid (head_loc, head) :: ((IdUid (_, x) :: _) as rest)
                  when head = qualified_prefix ->
                    collected <- StringSet.add x collected;
                    Ast.idAcc_of_list (IdUid (head_loc, helper_name) :: rest)

                | _ -> id)

          | _ ->
              super#ident id

      end


  (* Injecting the helper module into the implementation *)
  let () =
    AstFilters.register_str_item_filter (fun si ->
      let _loc = Ast.loc_of_str_item si in
      let helper_name = gen_helper_name _loc in
      let collector = make_reference_collector helper_name in
      let si = collector#str_item si in
      let qualified = collector#get_collected in
      match qualified with
        | [] ->
            si
        | ids ->
            <:str_item<
              module $uid:(helper_name)$ = struct
                $list:(ids |> List.map (fun id ->
                         <:str_item<
                           module $uid:(id)$ = $uid:(id)$
                         >>))$
              end;
              $(si)$;
            >>)


  (* Injecting the helper module into the interface *)
  let () =
    AstFilters.register_sig_item_filter (fun si ->
      let _loc = Ast.loc_of_sig_item si in
      let helper_name = gen_helper_name _loc in
      let collector = make_reference_collector helper_name in
      let si = collector#sig_item si in
      let qualified = collector#get_collected in
      match qualified with
        | [] ->
            si
        | ids ->
            <:sig_item<
              module $uid:(helper_name)$: sig
                $list:(ids |> List.map (fun id ->
                         <:sig_item<
                           module $uid:(id)$: module type of $uid:(id)$
                         >>))$
              end;
              $(si)$;
            >>)

end


module M = Camlp4.Register.AstFilter (Id) (Make)