Source file xast.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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
open Migrate_parsetree.Ast_405
open Utils
open List
module Longident = struct
include Longident
open Format
let rec format ppf = function
| Lident n -> pp_print_string ppf n
| Ldot (p, name) -> fprintf ppf "%a.%s" format p name
| Lapply (p1, p2) -> fprintf ppf "%a(%a)" format p1 format p2
let to_string l = ksprintf (fun x -> x) "%a" format l
end
module Ident = struct
include Ident
open Format
let format ppf id = pp_print_string ppf (Ident.name id)
let format_verbose = Ident.print_with_scope
end
module Path = struct
include Path
open Format
let rec format ppf = function
| Pident id -> Ident.format ppf id
| Pdot (p, name) -> fprintf ppf "%a.%s" format p name
| Papply (p1, p2) -> fprintf ppf "%a(%a)" format p1 format p2
let rec format_verbose ppf = function
| Pident id -> Ident.format_verbose ppf id
| Pdot (p, name) -> fprintf ppf "%a.%s" format_verbose p name
| Papply (p1, p2) -> fprintf ppf "%a(%a)" format_verbose p1 format_verbose p2
let to_string l = ksprintf (fun x -> x) "%a" format l
end
module Location = struct
include Location
let format = print_loc
let merge t1 t2 = { t1 with loc_end = t2.loc_end }
end
module XParsetree = struct
open Parsetree
let iter_core_type f ty = match ty.ptyp_desc with
Ptyp_any | Ptyp_var _ -> ()
| Ptyp_arrow (_, ty1, ty2) -> f ty1; f ty2
| Ptyp_tuple l
| Ptyp_constr (_, l)
| Ptyp_class (_, l) -> iter f l
| Ptyp_alias (ty, _) -> f ty
| Ptyp_object(s_a_cty_l, _) ->
iter (fun (_, _, cty) -> f cty) s_a_cty_l
| Ptyp_variant (rfs, _, _) ->
iter (function
| Rtag (_, _, _, l) -> iter f l
| Rinherit t -> f t) rfs
| Ptyp_poly (_, t) -> f t
| Ptyp_package (_, l_cty_s) ->
iter (fun (_, t) -> f t) l_cty_s
| Ptyp_extension _ -> ()
module LongidentSet = Set.Make(struct type t = Longident.t let compare = compare end)
let constrs_in_core_type_ ty =
let s = ref LongidentSet.empty in
let add l = s := LongidentSet.add l !s in
let rec f ty =
begin match ty.ptyp_desc with
| Ptyp_constr ({txt}, _) -> add txt
| Ptyp_class ({txt}, _) -> add txt
| _ -> ()
end;
iter_core_type f ty
in
f ty;
!s
let constrs_in_core_type ty =
LongidentSet.elements & constrs_in_core_type_ ty
let constrs_in_type_declaration td =
constrs_in_core_type
& Ast_helper.Typ.tuple
& concat_map (fun (ty1, ty2, _) -> [ty1; ty2]) td.ptype_cstrs
@ begin match td.ptype_kind with
| Ptype_abstract -> []
| Ptype_variant cds ->
concat_map (fun cd ->
(match cd.pcd_args with
| Pcstr_tuple ctys -> ctys
| Pcstr_record lds -> map (fun x -> x.pld_type) lds)
@ Option.to_list cd.pcd_res) cds
| Ptype_record ldl ->
map (fun ld -> ld.pld_type) ldl
| Ptype_open -> []
end
@ Option.to_list td.ptype_manifest
let sccs (es : ('v * 'v list) list) : 'v list list =
match es with
| [] -> []
| _ ->
let rec f cntr vns s p sccs (v : 'v * 'v list) =
let (v_, w_s) = v in
let vns = (v_,cntr) :: vns in
let s = v :: s in
let p = (v,cntr) :: p in
let cntr = cntr + 1 in
let cntr, vns, s, p, sccs =
fold_left (fun (cntr, vns, s, p, sccs) w_ ->
let w = w_, assoc w_ es in
match assoc_opt w_ vns with
| None -> f cntr vns s p sccs w
| Some n ->
let rec pop = function
| ((_,n')::_ as p) when n' <= n -> p
| _::vns -> pop vns
| [] -> assert false
in
cntr, vns, s, pop p, sccs) (cntr, vns, s, p, sccs) w_s
in
match p with
| [] -> assert false
| ((v'_,_),_) :: p when v_ = v'_ ->
let rec pop scc = function
| (v'_,_)::s ->
if v_ = v'_ then (v'_::scc), s
else pop (v'_::scc) s
| _ -> assert false
in
let scc, s = pop [] s in
cntr, vns, s, p, scc::sccs
| _ -> cntr, vns, s, p, sccs
in
let _, _, _, _, sccs = f 0 [] [] [] [] (List.hd es) in
sccs
let group_type_declarations tds =
let names = List.map (fun td -> td.ptype_name.txt) tds in
let alist = List.map (fun td -> td.ptype_name.txt, td) tds in
let mutually_defined td =
filter_map (function Longident.Lident s when List.mem s names -> Some s | _ -> None)
& constrs_in_type_declaration td
in
let graph, nonrecs = List.partition_map (fun td ->
match mutually_defined td with
| [] -> `Right td.ptype_name.txt
| ns -> `Left (td.ptype_name.txt, ns)) tds
in
let groups = sccs graph in
(List.map (List.map (flip List.assoc alist)) groups,
List.map (flip List.assoc alist) nonrecs)
let is_gadt type_decl = match type_decl.ptype_kind with
| Ptype_variant constrs -> List.exists (fun c -> c.pcd_res <> None) constrs
| _ -> false
end
let raise_errorf = Location.raise_errorf
type 'a loc = 'a Location.loc = { txt : 'a; loc : Location.t }