Source file renaming.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
open! Base
open! Ppxlib

type t =
  { universal : (Fresh_name.t, string loc) Result.t Map.M(String).t
  ; existential : bool
  }

module Binding_kind = struct
  type t =
    | Universally_bound of Fresh_name.t
    | Existentially_bound
end

let add_universally_bound t name ~prefix =
  { t with
    universal =
      Map.set
        t.universal
        ~key:name.txt
        ~data:(Ok (Fresh_name.create (prefix ^ name.txt) ~loc:name.loc))
  }
;;

let binding_kind t var ~loc =
  match Map.find t.universal var with
  | None ->
    if t.existential
    then Binding_kind.Existentially_bound
    else Location.raise_errorf ~loc "ppx_sexp_conv: unbound type variable '%s" var
  | Some (Ok fresh) -> Binding_kind.Universally_bound fresh
  | Some (Error { loc; txt }) -> Location.raise_errorf ~loc "%s" txt
;;

(* Return a map translating type variables appearing in the return type of a GADT
   constructor to their name in the type parameter list.

   For instance:

   {[
     type ('a, 'b) t = X : 'x * 'y -> ('x, 'y) t
   ]}

   will produce:

   {v
     "x" -> Ok "a"
     "y" -> Ok "b"
   v}

   If a variable appears twice in the return type it will map to [Error _]. If a
   variable cannot be mapped to a parameter of the type declaration, it will map to
   [Error] (for instance [A : 'a -> 'a list t]).

   It returns [original] on user error, to let the typer give the error message *)
let with_constructor_declaration original cd ~type_parameters:tps =
  (* Add all type variables of a type to a map. *)
  let add_typevars =
    object
      inherit [t] Ast_traverse.fold as super

      method! core_type ty t =
        match ty.ptyp_desc with
        | Ptyp_var var ->
          let error =
            { loc = ty.ptyp_loc
            ; txt = "ppx_sexp_conv: variable is not a parameter of the type constructor"
            }
          in
          { t with universal = Map.set t.universal ~key:var ~data:(Error error) }
        | _ -> super#core_type ty t
    end
  in
  let aux t tp_name tp_in_return_type =
    match tp_in_return_type.ptyp_desc with
    | Ptyp_var var ->
      let data =
        let loc = tp_in_return_type.ptyp_loc in
        if Map.mem t.universal var
        then Error { loc; txt = "ppx_sexp_conv: duplicate variable" }
        else (
          match Map.find original.universal tp_name with
          | Some result -> result
          | None -> Error { loc; txt = "ppx_sexp_conv: unbound type parameter" })
      in
      { t with universal = Map.set t.universal ~key:var ~data }
    | _ -> add_typevars#core_type tp_in_return_type t
  in
  match cd.pcd_res with
  | None -> original
  | Some ty ->
    (match ty.ptyp_desc with
     | Ptyp_constr (_, params) ->
       if List.length params <> List.length tps
       then original
       else
         Stdlib.ListLabels.fold_left2
           tps
           params
           ~init:{ existential = true; universal = Map.empty (module String) }
           ~f:aux
     | _ -> original)
;;

let of_type_declaration decl ~prefix =
  { existential = false
  ; universal =
      List.fold
        decl.ptype_params
        ~init:(Map.empty (module String))
        ~f:(fun map param ->
          let name = get_type_param_name param in
          Map.update map name.txt ~f:(function
            | None -> Ok (Fresh_name.create (prefix ^ name.txt) ~loc:name.loc)
            | Some _ ->
              Error { loc = name.loc; txt = "ppx_sexp_conv: duplicate variable" }))
  }
;;

let without_type () = { existential = false; universal = Map.empty (module String) }