/
browse_misc.ml
149 lines (140 loc) · 4.35 KB
/
browse_misc.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
let (>>=) a f = match a with
| Some a' -> f a'
| None -> None
let union_loc_opt a b = match a,b with
| None, None -> None
| (Some _ as l), None | None, (Some _ as l) -> l
| Some a, Some b -> Some (Location.union a b)
let rec signature_loc =
let open Types in
let rec mod_loc = function
| Mty_ident _ -> None
| Mty_functor (_,m1,m2) ->
union_loc_opt (mod_loc m1) (mod_loc m2)
| Mty_signature s ->
let rec find_first = function
| x :: xs -> (match signature_loc x with
| (Some _ as v) -> v
| None -> find_first xs)
| [] -> None
in
let a = find_first s and b = find_first (List.rev s) in
union_loc_opt a b
in
function
| Sig_value (_,v) -> Some v.val_loc
| Sig_type (_,t,_) -> Some t.type_loc
| Sig_exception (_,e) -> Some e.exn_loc
| Sig_modtype (_,Modtype_manifest m)
| Sig_module (_,m,_) -> mod_loc m
| Sig_modtype (_,Modtype_abstract) -> None
| Sig_class (_,_,_)
| Sig_class_type (_,_,_) -> None
let signature_ident =
let open Types in function
| Sig_value (i,_)
| Sig_type (i,_,_)
| Sig_exception (i,_)
| Sig_modtype (i,_)
| Sig_module (i,_,_)
| Sig_class (i,_,_)
| Sig_class_type (i,_,_) -> i
let print_constructor ppf c =
let open Types in
match c.cstr_args with
| [] ->
Printtyp.type_expr ppf ({ level = 0 ; id = 0 ; desc = c.cstr_res.desc })
| args ->
let desc = Tarrow ("",{ level = 0; id = 0; desc = Ttuple args}, c.cstr_res,Cok) in
Printtyp.type_expr ppf ({ level = 0 ; id = 0 ; desc })
let summary_prev =
let open Env in
function
| Env_empty -> None
| Env_open (s,_) | Env_value (s,_,_)
| Env_type (s,_,_) | Env_exception (s,_,_)
| Env_module (s,_,_) | Env_modtype (s,_,_)
| Env_class (s,_,_) | Env_cltype (s,_,_) ->
Some s
let signature_of_summary =
let open Env in
let open Types in
function
| Env_value (_,i,v) -> Some (Sig_value (i,v))
| Env_type (_,i,t) -> Some (Sig_type (i,t,Trec_not))
| Env_exception (_,i,e) -> Some (Sig_exception (i,e))
| Env_module (_,i,m) -> Some (Sig_module (i,m,Trec_not))
| Env_modtype (_,i,m) -> Some (Sig_modtype (i,m))
| Env_class (_,i,c) -> Some (Sig_class (i,c,Trec_not))
| Env_cltype (_,i,c) -> Some (Sig_class_type (i,c,Trec_not))
| Env_open _ | Env_empty -> None
let summary_at pos sum =
let cmp = Location.compare_pos pos in
let rec aux sum =
match signature_of_summary sum >>= signature_loc with
| None -> summary_prev sum >>= aux
| Some loc ->
match cmp loc with
| x when x < 0 -> None
| 0 -> Some sum
| x -> summary_prev sum >>= aux
in
aux sum
let signature_of_env env =
let open Types in
let sg = ref [] in
let append item = sg := item :: !sg in
let rec aux summary =
match summary with
| Env.Env_empty -> ()
(* Stop when encoutering extensions *)
| Env.Env_module (_,i,_) when i = Extensions.ident -> ()
| Env.Env_value (s,i,v) ->
append (Sig_value (i,v));
aux s
| Env.Env_type (s,i,t) ->
append (Sig_type (i,t,Trec_not)); (* Trec_not == bluff, FIXME *)
aux s
| Env.Env_exception (s,i,e) ->
append (Sig_exception (i,e));
aux s
| Env.Env_module (s,i,m) ->
append (Sig_module (i,m,Trec_not));
aux s
| Env.Env_modtype (s,i,mt) ->
append (Sig_modtype (i,mt));
aux s
| Env.Env_class (s,i,c) ->
append (Sig_class (i,c,Trec_not));
aux s
| Env.Env_cltype (s,i,ct) ->
append (Sig_class_type (i,ct,Trec_not));
aux s
| Env.Env_open (s,p) ->
aux s
in
let summary = Env.summary env in
aux summary;
Typemod.simplify_signature (!sg)
let rec dump_ts ts =
let dump_t { Browse. loc ; context ; nodes = lazy nodes } =
let kind = match context with
| Browse.Type _ -> "type"
| Browse.Expr _ -> "expr"
| Browse.Module _ -> "module"
| Browse.Modtype _ -> "modtype"
| Browse.Class (_, _) -> "class"
| Browse.ClassType _ -> "class_type"
| Browse.Other -> "??"
in
Protocol.with_location loc
[
"kind", `String kind;
"children", dump_ts nodes
]
in
let cmp_start { Browse.loc = l1 } { Browse.loc = l2 } =
Misc.compare_pos l1.Location.loc_start l2.Location.loc_end
in
let ts = List.sort cmp_start ts in
`List (List.map dump_t ts)