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
|
let empty_string = String.make 0 '_'
let non_empty_string s =
(* to protect against `ancient` segfaulting on statically allocated values *)
if s = "" then empty_string else s
module Kind = struct
type t =
| Doc (** Standalone doc comment *)
| Page (** Mld page *)
| Impl (** Source page *)
| Module
| Module_type
| Class
| Class_type
| Method
| Val of Typexpr.t
| Type_decl of string option
| Type_extension
| Extension_constructor of Typexpr.t
| Exception of Typexpr.t
| Constructor of Typexpr.t
| Field of Typexpr.t
let equal = ( = )
let get_type t =
match t with
| Val typ | Extension_constructor typ | Exception typ | Constructor typ | Field typ ->
Some typ
| Doc | Page | Impl | Module | Module_type | Class | Class_type | Method | Type_decl _
| Type_extension ->
None
end
module Package = struct
type t =
{ name : string
; version : string
}
let v ~name ~version =
{ name = non_empty_string name; version = non_empty_string version }
let compare a b = String.compare a.name b.name
let link { name; version } = "https://ocaml.org/p/" ^ name ^ "/" ^ version
end
type t =
{ name : string
; rhs : string option
; url : string
; kind : Kind.t
; cost : int
; doc_html : string
; pkg : Package.t
}
let pp fmt { name; rhs; url; kind = _; cost; doc_html; pkg = _ } =
Format.fprintf
fmt
"{ name = %s ; rhs = %a ; url = %s ; kind = . ; cost = %d ; doc_html = %s ; pkg = . }\n"
name
(Fmt.option Fmt.string)
rhs
url
cost
doc_html
let string_compare_shorter a b =
match Int.compare (String.length a) (String.length b) with
| 0 -> String.compare a b
| c -> c
let structural_compare a b =
match string_compare_shorter a.name b.name with
| 0 -> begin
match Package.compare a.pkg b.pkg with
| 0 -> begin
match Stdlib.compare a.kind b.kind with
| 0 -> begin
match string_compare_shorter a.doc_html b.doc_html with
| 0 -> String.compare a.url b.url
| c -> c
end
| c -> c
end
| c -> c
end
| c -> c
let compare a b =
if a == b
then 0
else begin
match Int.compare a.cost b.cost with
| 0 -> structural_compare a b
| cmp -> cmp
end
let equal a b = compare a b = 0
let stdlib_link ~name t =
let path, hashref =
match List.rev name, String.index_opt t.url '#' with
| _ :: path, Some idx ->
let idx = idx + 1 in
let tgt =
match String.index_from_opt t.url idx '-' with
| None -> String.sub t.url idx (String.length t.url - idx)
| Some jdx ->
let kind = String.sub t.url idx (jdx - idx) in
let jdx = jdx + 1 in
let target = String.sub t.url jdx (String.length t.url - jdx) in
String.uppercase_ascii kind ^ target
in
path, "#" ^ tgt
| path, _ -> path, ""
in
let path = String.concat "." (List.rev path) in
"https://v2.ocaml.org/releases/5.1/api/" ^ path ^ ".html" ^ hashref
let link t =
let fullname = String.split_on_char '.' t.name in
match fullname with
| "Stdlib" :: name -> stdlib_link ~name t
| _ ->
let pkg_link = Package.link t.pkg in
let rec align n ys =
match ys with
| _ when n = 0 -> []
| [] -> []
| y :: ys -> y :: align (n - 1) ys
in
let length = List.length fullname in
let length =
match String.index_opt t.url '#' with
| None -> length + 1
| Some idx ->
let tgt = String.sub t.url idx (String.length t.url - idx) in
let count = ref 0 in
String.iter
(function
| '.' -> incr count
| _ -> ())
tgt ;
length - !count
in
let path = align length (List.rev (String.split_on_char '/' t.url)) in
let path = String.concat "/" (List.rev path) in
pkg_link ^ "/doc/" ^ path
let v ~name ~kind ~cost ~rhs ~doc_html ~url ~pkg () =
{ name = non_empty_string name
; kind
; url = non_empty_string url
; cost
; doc_html = non_empty_string doc_html
; pkg
; rhs = Option.map non_empty_string rhs
}
|
