jon.recoil.org
this repo has no description
feat: extract odoc-scrollycode-extension into standalone package
Move scrollycode extension from odoc/src/extensions/scrollycode/ into
its own top-level package following the pattern of other odoc extensions
like odoc-admonition-extension. The package provides @scrolly.warm,
@scrolly.dark, and @scrolly.notebook tags for scroll-driven code
tutorials in odoc documentation.
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
-3
src/extensions/scrollycode/dune
-3
src/extensions/scrollycode/dune
-1396
src/extensions/scrollycode/scrollycode_extension.ml
-1396
src/extensions/scrollycode/scrollycode_extension.ml
···
1
-
(** Scrollycode Extension for odoc
2
-
3
-
Provides scroll-driven code tutorials with three visual themes:
4
-
- warm: Earthy, bookish aesthetic (Fraunces + Source Serif)
5
-
- dark: Cinematic terminal aesthetic (JetBrains Mono + Outfit)
6
-
- notebook: Clean editorial aesthetic (Newsreader + DM Sans)
7
-
8
-
Authoring format uses @scrolly.<theme> custom tags with an ordered
9
-
list inside, where each list item is a tutorial step containing
10
-
a bold title, prose paragraphs, and a code block. *)
11
-
12
-
module Comment = Odoc_model.Comment
13
-
module Location_ = Odoc_model.Location_
14
-
module Block = Odoc_document.Types.Block
15
-
module Inline = Odoc_document.Types.Inline
16
-
17
-
(** {1 Step Extraction} *)
18
-
19
-
(** A single tutorial step extracted from the ordered list structure *)
20
-
type step = {
21
-
title : string;
22
-
prose : string;
23
-
code : string;
24
-
focus : int list; (** 1-based line numbers to highlight *)
25
-
}
26
-
27
-
(** Extract plain text from inline elements *)
28
-
let rec text_of_inline (el : Comment.inline_element Location_.with_location) =
29
-
match el.Location_.value with
30
-
| `Space -> " "
31
-
| `Word w -> w
32
-
| `Code_span c -> "`" ^ c ^ "`"
33
-
| `Math_span m -> m
34
-
| `Raw_markup (_, r) -> r
35
-
| `Styled (_, content) -> text_of_inlines content
36
-
| `Reference (_, content) -> text_of_link_content content
37
-
| `Link (_, content) -> text_of_link_content content
38
-
39
-
and text_of_inlines content =
40
-
String.concat "" (List.map text_of_inline content)
41
-
42
-
and text_of_link_content content =
43
-
String.concat "" (List.map text_of_non_link content)
44
-
45
-
and text_of_non_link
46
-
(el : Comment.non_link_inline_element Location_.with_location) =
47
-
match el.Location_.value with
48
-
| `Space -> " "
49
-
| `Word w -> w
50
-
| `Code_span c -> "`" ^ c ^ "`"
51
-
| `Math_span m -> m
52
-
| `Raw_markup (_, r) -> r
53
-
| `Styled (_, content) -> text_of_link_content content
54
-
55
-
let text_of_paragraph (p : Comment.paragraph) =
56
-
String.concat "" (List.map text_of_inline p)
57
-
58
-
(** Extract title, prose, code and focus lines from a single list item *)
59
-
let extract_step
60
-
(item : Comment.nestable_block_element Location_.with_location list) : step
61
-
=
62
-
let title = ref "" in
63
-
let prose_parts = ref [] in
64
-
let code = ref "" in
65
-
let focus = ref [] in
66
-
List.iter
67
-
(fun (el : Comment.nestable_block_element Location_.with_location) ->
68
-
match el.Location_.value with
69
-
| `Paragraph p -> (
70
-
let text = text_of_paragraph p in
71
-
(* Check if the paragraph starts with bold text — that's the title *)
72
-
match p with
73
-
| first :: _
74
-
when (match first.Location_.value with
75
-
| `Styled (`Bold, _) -> true
76
-
| _ -> false) ->
77
-
if !title = "" then title := text
78
-
else prose_parts := text :: !prose_parts
79
-
| _ -> prose_parts := text :: !prose_parts)
80
-
| `Code_block { content = code_content; _ } ->
81
-
let code_text = code_content.Location_.value in
82
-
(* Check for focus annotation in the code: lines starting with >>> *)
83
-
let lines = String.split_on_char '\n' code_text in
84
-
let focused_lines = ref [] in
85
-
let clean_lines =
86
-
List.mapi
87
-
(fun i line ->
88
-
if
89
-
String.length line >= 4
90
-
&& String.sub line 0 4 = "(* >"
91
-
then (
92
-
focused_lines := (i + 1) :: !focused_lines;
93
-
(* Remove the focus marker *)
94
-
let rest = String.sub line 4 (String.length line - 4) in
95
-
let rest =
96
-
if
97
-
String.length rest >= 4
98
-
&& String.sub rest (String.length rest - 4) 4 = "< *)"
99
-
then String.sub rest 0 (String.length rest - 4)
100
-
else rest
101
-
in
102
-
String.trim rest)
103
-
else line)
104
-
lines
105
-
in
106
-
code := String.concat "\n" clean_lines;
107
-
focus := List.rev !focused_lines
108
-
| `Verbatim v -> prose_parts := v :: !prose_parts
109
-
| _ -> ())
110
-
item;
111
-
{
112
-
title = !title;
113
-
prose = String.concat "\n\n" (List.rev !prose_parts);
114
-
code = !code;
115
-
focus = !focus;
116
-
}
117
-
118
-
(** Extract all steps from the tag content (expects an ordered list) *)
119
-
let extract_steps
120
-
(content :
121
-
Comment.nestable_block_element Location_.with_location list) :
122
-
string * step list =
123
-
(* First element might be a paragraph with the tutorial title *)
124
-
let tutorial_title = ref "Tutorial" in
125
-
let steps = ref [] in
126
-
List.iter
127
-
(fun (el : Comment.nestable_block_element Location_.with_location) ->
128
-
match el.Location_.value with
129
-
| `Paragraph p ->
130
-
let text = text_of_paragraph p in
131
-
if !steps = [] then tutorial_title := text
132
-
| `List (`Ordered, items) ->
133
-
steps := List.map extract_step items
134
-
| _ -> ())
135
-
content;
136
-
(!tutorial_title, !steps)
137
-
138
-
(** {1 HTML Escaping} *)
139
-
140
-
let html_escape s =
141
-
let buf = Buffer.create (String.length s) in
142
-
String.iter
143
-
(function
144
-
| '&' -> Buffer.add_string buf "&"
145
-
| '<' -> Buffer.add_string buf "<"
146
-
| '>' -> Buffer.add_string buf ">"
147
-
| '"' -> Buffer.add_string buf """
148
-
| c -> Buffer.add_char buf c)
149
-
s;
150
-
Buffer.contents buf
151
-
152
-
(** {1 OCaml Syntax Highlighting}
153
-
154
-
A simple lexer-based highlighter for OCaml code. Produces HTML spans
155
-
with classes for keywords, types, strings, comments, operators. *)
156
-
157
-
let ocaml_keywords =
158
-
[
159
-
"let"; "in"; "if"; "then"; "else"; "match"; "with"; "fun"; "function";
160
-
"type"; "module"; "struct"; "sig"; "end"; "open"; "include"; "val";
161
-
"rec"; "and"; "of"; "when"; "as"; "begin"; "do"; "done"; "for"; "to";
162
-
"while"; "downto"; "try"; "exception"; "raise"; "mutable"; "ref";
163
-
"true"; "false"; "assert"; "failwith"; "not";
164
-
]
165
-
166
-
let ocaml_types =
167
-
[
168
-
"int"; "float"; "string"; "bool"; "unit"; "list"; "option"; "array";
169
-
"char"; "bytes"; "result"; "exn"; "ref";
170
-
]
171
-
172
-
(** Tokenize and highlight OCaml code into HTML *)
173
-
let highlight_ocaml code =
174
-
let len = String.length code in
175
-
let buf = Buffer.create (len * 2) in
176
-
let i = ref 0 in
177
-
let peek () = if !i < len then Some code.[!i] else None in
178
-
let advance () = incr i in
179
-
let current () = code.[!i] in
180
-
while !i < len do
181
-
match current () with
182
-
(* Comments *)
183
-
| '(' when !i + 1 < len && code.[!i + 1] = '*' ->
184
-
Buffer.add_string buf "<span class=\"hl-comment\">";
185
-
Buffer.add_string buf "(*";
186
-
i := !i + 2;
187
-
let depth = ref 1 in
188
-
while !depth > 0 && !i < len do
189
-
if !i + 1 < len && code.[!i] = '(' && code.[!i + 1] = '*' then (
190
-
Buffer.add_string buf "(*";
191
-
i := !i + 2;
192
-
incr depth)
193
-
else if !i + 1 < len && code.[!i] = '*' && code.[!i + 1] = ')' then (
194
-
Buffer.add_string buf "*)";
195
-
i := !i + 2;
196
-
decr depth)
197
-
else (
198
-
Buffer.add_string buf (html_escape (String.make 1 code.[!i]));
199
-
advance ())
200
-
done;
201
-
Buffer.add_string buf "</span>"
202
-
(* Strings *)
203
-
| '"' ->
204
-
Buffer.add_string buf "<span class=\"hl-string\">";
205
-
Buffer.add_char buf '"';
206
-
advance ();
207
-
while !i < len && current () <> '"' do
208
-
if current () = '\\' && !i + 1 < len then (
209
-
Buffer.add_string buf (html_escape (String.make 1 (current ())));
210
-
advance ();
211
-
Buffer.add_string buf (html_escape (String.make 1 (current ())));
212
-
advance ())
213
-
else (
214
-
Buffer.add_string buf (html_escape (String.make 1 (current ())));
215
-
advance ())
216
-
done;
217
-
if !i < len then (
218
-
Buffer.add_char buf '"';
219
-
advance ());
220
-
Buffer.add_string buf "</span>"
221
-
(* Char literals *)
222
-
| '\'' when !i + 2 < len && code.[!i + 2] = '\'' ->
223
-
Buffer.add_string buf "<span class=\"hl-string\">";
224
-
Buffer.add_char buf '\'';
225
-
advance ();
226
-
Buffer.add_string buf (html_escape (String.make 1 (current ())));
227
-
advance ();
228
-
Buffer.add_char buf '\'';
229
-
advance ();
230
-
Buffer.add_string buf "</span>"
231
-
(* Numbers *)
232
-
| '0' .. '9' ->
233
-
Buffer.add_string buf "<span class=\"hl-number\">";
234
-
while
235
-
!i < len
236
-
&&
237
-
match current () with
238
-
| '0' .. '9' | '.' | '_' | 'x' | 'o' | 'b' | 'a' .. 'f'
239
-
| 'A' .. 'F' ->
240
-
true
241
-
| _ -> false
242
-
do
243
-
Buffer.add_char buf (current ());
244
-
advance ()
245
-
done;
246
-
Buffer.add_string buf "</span>"
247
-
(* Identifiers and keywords *)
248
-
| 'a' .. 'z' | '_' ->
249
-
let start = !i in
250
-
while
251
-
!i < len
252
-
&&
253
-
match current () with
254
-
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'' -> true
255
-
| _ -> false
256
-
do
257
-
advance ()
258
-
done;
259
-
let word = String.sub code start (!i - start) in
260
-
if List.mem word ocaml_keywords then
261
-
Buffer.add_string buf
262
-
(Printf.sprintf "<span class=\"hl-keyword\">%s</span>"
263
-
(html_escape word))
264
-
else if List.mem word ocaml_types then
265
-
Buffer.add_string buf
266
-
(Printf.sprintf "<span class=\"hl-type\">%s</span>"
267
-
(html_escape word))
268
-
else Buffer.add_string buf (html_escape word)
269
-
(* Module/constructor names (capitalized identifiers) *)
270
-
| 'A' .. 'Z' ->
271
-
let start = !i in
272
-
while
273
-
!i < len
274
-
&&
275
-
match current () with
276
-
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'' -> true
277
-
| _ -> false
278
-
do
279
-
advance ()
280
-
done;
281
-
let word = String.sub code start (!i - start) in
282
-
Buffer.add_string buf
283
-
(Printf.sprintf "<span class=\"hl-module\">%s</span>"
284
-
(html_escape word))
285
-
(* Operators *)
286
-
| '|' | '-' | '+' | '*' | '/' | '=' | '<' | '>' | '@' | '^' | '~'
287
-
| '!' | '?' | '%' | '&' ->
288
-
Buffer.add_string buf "<span class=\"hl-operator\">";
289
-
Buffer.add_string buf (html_escape (String.make 1 (current ())));
290
-
advance ();
291
-
(* Consume multi-char operators *)
292
-
while
293
-
!i < len
294
-
&&
295
-
match current () with
296
-
| '|' | '-' | '+' | '*' | '/' | '=' | '<' | '>' | '@' | '^'
297
-
| '~' | '!' | '?' | '%' | '&' ->
298
-
true
299
-
| _ -> false
300
-
do
301
-
Buffer.add_string buf (html_escape (String.make 1 (current ())));
302
-
advance ()
303
-
done;
304
-
Buffer.add_string buf "</span>"
305
-
(* Punctuation *)
306
-
| ':' | ';' | '.' | ',' | '[' | ']' | '{' | '}' | '(' | ')' ->
307
-
Buffer.add_string buf
308
-
(Printf.sprintf "<span class=\"hl-punct\">%s</span>"
309
-
(html_escape (String.make 1 (current ()))));
310
-
advance ()
311
-
(* Arrow special case: -> *)
312
-
| ' ' | '\t' | '\n' | '\r' ->
313
-
Buffer.add_char buf (current ());
314
-
advance ()
315
-
| _ ->
316
-
let _ = peek () in
317
-
Buffer.add_string buf (html_escape (String.make 1 (current ())));
318
-
advance ()
319
-
done;
320
-
Buffer.contents buf
321
-
322
-
(** {1 Shared JavaScript}
323
-
324
-
The scrollycode runtime handles IntersectionObserver-based step
325
-
detection and line-level transition animations. *)
326
-
327
-
let shared_js =
328
-
{|
329
-
(function() {
330
-
'use strict';
331
-
332
-
function initScrollycode(container) {
333
-
var steps = container.querySelectorAll('.sc-step');
334
-
var codeBody = container.querySelector('.sc-code-body');
335
-
var stepBadge = container.querySelector('.sc-step-badge');
336
-
var pips = container.querySelectorAll('.sc-pip');
337
-
var currentStep = -1;
338
-
339
-
function parseLines(el) {
340
-
if (!el) return [];
341
-
var items = el.querySelectorAll('.sc-line');
342
-
return Array.from(items).map(function(line) {
343
-
return { id: line.dataset.id, html: line.innerHTML, focused: line.classList.contains('sc-focused') };
344
-
});
345
-
}
346
-
347
-
function renderStep(index) {
348
-
if (index === currentStep || index < 0 || index >= steps.length) return;
349
-
350
-
var stepEl = steps[index];
351
-
var codeSlot = stepEl.querySelector('.sc-code-slot');
352
-
var newLines = parseLines(codeSlot);
353
-
var oldLines = parseLines(codeBody);
354
-
var oldById = {};
355
-
oldLines.forEach(function(l) { oldById[l.id] = l; });
356
-
var newById = {};
357
-
newLines.forEach(function(l) { newById[l.id] = l; });
358
-
359
-
// Determine exiting lines
360
-
var exiting = oldLines.filter(function(l) { return !newById[l.id]; });
361
-
362
-
// Animate exit
363
-
exiting.forEach(function(l, i) {
364
-
var el = codeBody.querySelector('[data-id="' + l.id + '"]');
365
-
if (el) {
366
-
el.style.animationDelay = (i * 30) + 'ms';
367
-
el.classList.add('sc-exiting');
368
-
}
369
-
});
370
-
371
-
var exitTime = exiting.length > 0 ? 200 + exiting.length * 30 : 0;
372
-
373
-
setTimeout(function() {
374
-
// Rebuild DOM
375
-
codeBody.innerHTML = '';
376
-
newLines.forEach(function(l, i) {
377
-
var div = document.createElement('div');
378
-
div.className = 'sc-line' + (l.focused ? ' sc-focused' : '') + (!oldById[l.id] ? ' sc-entering' : '');
379
-
div.dataset.id = l.id;
380
-
div.innerHTML = '<span class="sc-line-number">' + (i + 1) + '</span>' + l.html;
381
-
if (!oldById[l.id]) {
382
-
div.style.animationDelay = (i * 25) + 'ms';
383
-
}
384
-
codeBody.appendChild(div);
385
-
});
386
-
387
-
// Update badge and pips
388
-
if (stepBadge) stepBadge.textContent = (index + 1) + ' / ' + steps.length;
389
-
pips.forEach(function(pip, i) {
390
-
pip.classList.toggle('sc-active', i === index);
391
-
});
392
-
}, exitTime);
393
-
394
-
currentStep = index;
395
-
}
396
-
397
-
// Set up IntersectionObserver
398
-
var observer = new IntersectionObserver(function(entries) {
399
-
entries.forEach(function(entry) {
400
-
if (entry.isIntersecting) {
401
-
var idx = parseInt(entry.target.dataset.stepIndex, 10);
402
-
renderStep(idx);
403
-
}
404
-
});
405
-
}, {
406
-
rootMargin: '-30% 0px -30% 0px',
407
-
threshold: 0
408
-
});
409
-
410
-
steps.forEach(function(step) { observer.observe(step); });
411
-
412
-
// Initialize first step
413
-
renderStep(0);
414
-
}
415
-
416
-
// Initialize all scrollycode containers on the page
417
-
document.addEventListener('DOMContentLoaded', function() {
418
-
document.querySelectorAll('.sc-container').forEach(initScrollycode);
419
-
});
420
-
})();
421
-
|}
422
-
423
-
(** {1 Theme: Warm Workshop}
424
-
425
-
Earthy, bookish. Cream background, burnt sienna accents.
426
-
Fraunces display + Source Serif 4 body.
427
-
Dark navy code panel with warm syntax highlighting. *)
428
-
429
-
let warm_css =
430
-
{|
431
-
.sc-container.sc-warm {
432
-
--sc-bg: #f5f0e6;
433
-
--sc-text: #2c2416;
434
-
--sc-text-dim: #8a7c6a;
435
-
--sc-accent: #c25832;
436
-
--sc-accent-soft: rgba(194, 88, 50, 0.08);
437
-
--sc-code-bg: #1a1a2e;
438
-
--sc-code-text: #d4d0c8;
439
-
--sc-code-gutter: #3a3a52;
440
-
--sc-border: rgba(44, 36, 22, 0.1);
441
-
--sc-focus-bg: rgba(194, 88, 50, 0.06);
442
-
--sc-panel-radius: 12px;
443
-
font-family: 'Source Serif 4', Georgia, serif;
444
-
}
445
-
446
-
.sc-container.sc-warm .sc-hero {
447
-
background: var(--sc-bg);
448
-
text-align: center;
449
-
padding: 5rem 2rem 3rem;
450
-
border-bottom: 1px solid var(--sc-border);
451
-
}
452
-
453
-
.sc-container.sc-warm .sc-hero h1 {
454
-
font-family: 'Fraunces', serif;
455
-
font-size: clamp(2.2rem, 5vw, 3.4rem);
456
-
font-weight: 800;
457
-
font-style: italic;
458
-
color: var(--sc-text);
459
-
letter-spacing: -0.03em;
460
-
line-height: 1.1;
461
-
margin-bottom: 0.75rem;
462
-
}
463
-
464
-
.sc-container.sc-warm .sc-hero p {
465
-
color: var(--sc-text-dim);
466
-
font-size: 1.05rem;
467
-
max-width: 48ch;
468
-
margin: 0 auto;
469
-
line-height: 1.6;
470
-
}
471
-
472
-
.sc-container.sc-warm .sc-tutorial {
473
-
display: flex;
474
-
gap: 0;
475
-
background: var(--sc-bg);
476
-
position: relative;
477
-
}
478
-
479
-
.sc-container.sc-warm .sc-steps-col {
480
-
flex: 1;
481
-
min-width: 0;
482
-
padding: 2rem 2.5rem 50vh 2.5rem;
483
-
}
484
-
485
-
.sc-container.sc-warm .sc-code-col {
486
-
width: 52%;
487
-
flex-shrink: 0;
488
-
}
489
-
490
-
.sc-container.sc-warm .sc-step {
491
-
min-height: 70vh;
492
-
display: flex;
493
-
flex-direction: column;
494
-
justify-content: center;
495
-
padding: 2rem 0;
496
-
}
497
-
498
-
.sc-container.sc-warm .sc-step-number {
499
-
font-family: 'Source Code Pro', monospace;
500
-
font-size: 0.7rem;
501
-
font-weight: 600;
502
-
letter-spacing: 0.1em;
503
-
color: var(--sc-accent);
504
-
text-transform: uppercase;
505
-
margin-bottom: 0.5rem;
506
-
}
507
-
508
-
.sc-container.sc-warm .sc-step h2 {
509
-
font-family: 'Fraunces', serif;
510
-
font-size: 1.5rem;
511
-
font-weight: 700;
512
-
color: var(--sc-text);
513
-
letter-spacing: -0.02em;
514
-
margin-bottom: 0.75rem;
515
-
line-height: 1.25;
516
-
}
517
-
518
-
.sc-container.sc-warm .sc-step p {
519
-
color: var(--sc-text-dim);
520
-
font-size: 0.95rem;
521
-
line-height: 1.7;
522
-
max-width: 44ch;
523
-
}
524
-
525
-
.sc-container.sc-warm .sc-code-panel {
526
-
position: sticky;
527
-
top: 10vh;
528
-
height: 80vh;
529
-
margin: 0 2rem 0 0;
530
-
background: var(--sc-code-bg);
531
-
border-radius: var(--sc-panel-radius);
532
-
overflow: hidden;
533
-
display: flex;
534
-
flex-direction: column;
535
-
box-shadow: 0 20px 60px rgba(26, 26, 46, 0.3), 0 0 0 1px rgba(255,255,255,0.03) inset;
536
-
}
537
-
538
-
.sc-container.sc-warm .sc-code-header {
539
-
display: flex;
540
-
align-items: center;
541
-
padding: 0.85rem 1.25rem;
542
-
background: rgba(255,255,255,0.03);
543
-
border-bottom: 1px solid rgba(255,255,255,0.06);
544
-
gap: 0.6rem;
545
-
}
546
-
547
-
.sc-container.sc-warm .sc-dots {
548
-
display: flex;
549
-
gap: 6px;
550
-
}
551
-
552
-
.sc-container.sc-warm .sc-dots span {
553
-
width: 10px;
554
-
height: 10px;
555
-
border-radius: 50%;
556
-
}
557
-
558
-
.sc-container.sc-warm .sc-dots span:nth-child(1) { background: #ff5f57; }
559
-
.sc-container.sc-warm .sc-dots span:nth-child(2) { background: #ffbd2e; }
560
-
.sc-container.sc-warm .sc-dots span:nth-child(3) { background: #28c840; }
561
-
562
-
.sc-container.sc-warm .sc-filename {
563
-
font-family: 'Source Code Pro', monospace;
564
-
font-size: 0.72rem;
565
-
color: rgba(255,255,255,0.35);
566
-
letter-spacing: 0.04em;
567
-
flex: 1;
568
-
text-align: center;
569
-
}
570
-
571
-
.sc-container.sc-warm .sc-step-badge {
572
-
font-family: 'Source Code Pro', monospace;
573
-
font-size: 0.65rem;
574
-
color: rgba(255,255,255,0.25);
575
-
letter-spacing: 0.06em;
576
-
}
577
-
578
-
.sc-container.sc-warm .sc-code-body {
579
-
flex: 1;
580
-
overflow-y: auto;
581
-
padding: 1.25rem 0;
582
-
font-family: 'Source Code Pro', monospace;
583
-
font-size: 0.82rem;
584
-
line-height: 1.7;
585
-
color: var(--sc-code-text);
586
-
}
587
-
588
-
.sc-container.sc-warm .sc-line {
589
-
padding: 0 1.25rem;
590
-
white-space: pre;
591
-
transition: opacity 0.3s ease;
592
-
opacity: 0.35;
593
-
}
594
-
595
-
.sc-container.sc-warm .sc-line.sc-focused {
596
-
opacity: 1;
597
-
background: rgba(194, 88, 50, 0.06);
598
-
}
599
-
600
-
.sc-container.sc-warm .sc-line-number {
601
-
display: inline-block;
602
-
width: 3ch;
603
-
text-align: right;
604
-
margin-right: 1.5ch;
605
-
color: var(--sc-code-gutter);
606
-
user-select: none;
607
-
}
608
-
609
-
/* Syntax highlighting */
610
-
.sc-container.sc-warm .hl-keyword { color: #f0a6a0; font-weight: 500; }
611
-
.sc-container.sc-warm .hl-type { color: #8ec8e8; }
612
-
.sc-container.sc-warm .hl-string { color: #b8d89a; }
613
-
.sc-container.sc-warm .hl-comment { color: #6a6a82; font-style: italic; }
614
-
.sc-container.sc-warm .hl-number { color: #ddb97a; }
615
-
.sc-container.sc-warm .hl-module { color: #e8c87a; }
616
-
.sc-container.sc-warm .hl-operator { color: #c8a8d8; }
617
-
.sc-container.sc-warm .hl-punct { color: #7a7a92; }
618
-
619
-
/* Progress pips */
620
-
.sc-container.sc-warm .sc-progress {
621
-
position: fixed;
622
-
left: 1.5rem;
623
-
top: 50%;
624
-
transform: translateY(-50%);
625
-
display: flex;
626
-
flex-direction: column;
627
-
gap: 8px;
628
-
z-index: 100;
629
-
}
630
-
631
-
.sc-container.sc-warm .sc-pip {
632
-
width: 6px;
633
-
height: 6px;
634
-
border-radius: 50%;
635
-
background: var(--sc-border);
636
-
transition: all 0.3s ease;
637
-
}
638
-
639
-
.sc-container.sc-warm .sc-pip.sc-active {
640
-
background: var(--sc-accent);
641
-
box-shadow: 0 0 8px rgba(194, 88, 50, 0.4);
642
-
transform: scale(1.4);
643
-
}
644
-
645
-
/* Animations */
646
-
@keyframes sc-line-exit {
647
-
0% { opacity: 1; transform: translateX(0); }
648
-
100% { opacity: 0; transform: translateX(-30px); }
649
-
}
650
-
651
-
@keyframes sc-line-enter {
652
-
0% { opacity: 0; transform: translateX(30px); }
653
-
100% { opacity: 1; transform: translateX(0); }
654
-
}
655
-
656
-
.sc-container.sc-warm .sc-line.sc-exiting {
657
-
animation: sc-line-exit 0.2s cubic-bezier(0.22, 1, 0.36, 1) forwards;
658
-
}
659
-
660
-
.sc-container.sc-warm .sc-line.sc-entering {
661
-
animation: sc-line-enter 0.25s cubic-bezier(0.22, 1, 0.36, 1) both;
662
-
}
663
-
664
-
/* Hidden code slot */
665
-
.sc-code-slot { display: none; }
666
-
|}
667
-
668
-
(** {1 Theme: Dark Terminal}
669
-
670
-
Cinematic dark theme. Near-black background, phosphor green and amber.
671
-
JetBrains Mono + Outfit geometric sans.
672
-
Code panel is hero-sized, prose is a narrow overlay strip. *)
673
-
674
-
let dark_css =
675
-
{|
676
-
.sc-container.sc-dark {
677
-
--sc-bg: #0a0a0f;
678
-
--sc-text: #e8e6f0;
679
-
--sc-text-dim: #6e6b80;
680
-
--sc-accent: #4ade80;
681
-
--sc-accent-alt: #fbbf24;
682
-
--sc-code-bg: #0f0f18;
683
-
--sc-code-text: #c8c5d8;
684
-
--sc-code-gutter: #2a2a3e;
685
-
--sc-border: rgba(255, 255, 255, 0.06);
686
-
--sc-panel-radius: 0;
687
-
font-family: 'Outfit', sans-serif;
688
-
background: var(--sc-bg);
689
-
color: var(--sc-text);
690
-
}
691
-
692
-
.sc-container.sc-dark .sc-hero {
693
-
background: var(--sc-bg);
694
-
text-align: left;
695
-
padding: 8rem 4rem 4rem;
696
-
max-width: 800px;
697
-
position: relative;
698
-
}
699
-
700
-
.sc-container.sc-dark .sc-hero::before {
701
-
content: '';
702
-
position: absolute;
703
-
top: 0;
704
-
left: 0;
705
-
right: 0;
706
-
bottom: 0;
707
-
background: radial-gradient(ellipse at 20% 50%, rgba(74, 222, 128, 0.04) 0%, transparent 60%);
708
-
pointer-events: none;
709
-
}
710
-
711
-
.sc-container.sc-dark .sc-hero h1 {
712
-
font-family: 'Outfit', sans-serif;
713
-
font-size: clamp(2.8rem, 6vw, 4.5rem);
714
-
font-weight: 800;
715
-
color: var(--sc-text);
716
-
letter-spacing: -0.04em;
717
-
line-height: 1.0;
718
-
margin-bottom: 1.25rem;
719
-
}
720
-
721
-
.sc-container.sc-dark .sc-hero h1 em {
722
-
font-style: normal;
723
-
color: var(--sc-accent);
724
-
}
725
-
726
-
.sc-container.sc-dark .sc-hero p {
727
-
color: var(--sc-text-dim);
728
-
font-size: 1.1rem;
729
-
max-width: 50ch;
730
-
line-height: 1.6;
731
-
font-weight: 300;
732
-
}
733
-
734
-
.sc-container.sc-dark .sc-tutorial {
735
-
display: flex;
736
-
gap: 0;
737
-
position: relative;
738
-
}
739
-
740
-
.sc-container.sc-dark .sc-steps-col {
741
-
width: 38%;
742
-
flex-shrink: 0;
743
-
padding: 2rem 2.5rem 50vh 4rem;
744
-
border-right: 1px solid var(--sc-border);
745
-
}
746
-
747
-
.sc-container.sc-dark .sc-code-col {
748
-
flex: 1;
749
-
min-width: 0;
750
-
}
751
-
752
-
.sc-container.sc-dark .sc-step {
753
-
min-height: 70vh;
754
-
display: flex;
755
-
flex-direction: column;
756
-
justify-content: center;
757
-
padding: 2rem 0;
758
-
}
759
-
760
-
.sc-container.sc-dark .sc-step-number {
761
-
font-family: 'JetBrains Mono', monospace;
762
-
font-size: 0.65rem;
763
-
font-weight: 700;
764
-
letter-spacing: 0.15em;
765
-
color: var(--sc-accent);
766
-
text-transform: uppercase;
767
-
margin-bottom: 0.75rem;
768
-
display: flex;
769
-
align-items: center;
770
-
gap: 0.75rem;
771
-
}
772
-
773
-
.sc-container.sc-dark .sc-step-number::after {
774
-
content: '';
775
-
flex: 1;
776
-
height: 1px;
777
-
background: var(--sc-border);
778
-
}
779
-
780
-
.sc-container.sc-dark .sc-step h2 {
781
-
font-family: 'Outfit', sans-serif;
782
-
font-size: 1.4rem;
783
-
font-weight: 700;
784
-
color: var(--sc-text);
785
-
letter-spacing: -0.02em;
786
-
margin-bottom: 0.75rem;
787
-
line-height: 1.2;
788
-
}
789
-
790
-
.sc-container.sc-dark .sc-step p {
791
-
color: var(--sc-text-dim);
792
-
font-size: 0.9rem;
793
-
line-height: 1.7;
794
-
max-width: 40ch;
795
-
font-weight: 300;
796
-
}
797
-
798
-
.sc-container.sc-dark .sc-code-panel {
799
-
position: sticky;
800
-
top: 0;
801
-
height: 100vh;
802
-
background: var(--sc-code-bg);
803
-
display: flex;
804
-
flex-direction: column;
805
-
border-left: 1px solid var(--sc-border);
806
-
}
807
-
808
-
.sc-container.sc-dark .sc-code-header {
809
-
display: flex;
810
-
align-items: center;
811
-
padding: 1rem 1.5rem;
812
-
border-bottom: 1px solid var(--sc-border);
813
-
gap: 1rem;
814
-
}
815
-
816
-
.sc-container.sc-dark .sc-dots {
817
-
display: flex;
818
-
gap: 6px;
819
-
}
820
-
821
-
.sc-container.sc-dark .sc-dots span {
822
-
width: 8px;
823
-
height: 8px;
824
-
border-radius: 50%;
825
-
background: var(--sc-code-gutter);
826
-
}
827
-
828
-
.sc-container.sc-dark .sc-filename {
829
-
font-family: 'JetBrains Mono', monospace;
830
-
font-size: 0.7rem;
831
-
color: var(--sc-text-dim);
832
-
letter-spacing: 0.04em;
833
-
flex: 1;
834
-
}
835
-
836
-
.sc-container.sc-dark .sc-step-badge {
837
-
font-family: 'JetBrains Mono', monospace;
838
-
font-size: 0.6rem;
839
-
color: var(--sc-accent);
840
-
letter-spacing: 0.08em;
841
-
background: rgba(74, 222, 128, 0.08);
842
-
padding: 0.25em 0.75em;
843
-
border-radius: 3px;
844
-
}
845
-
846
-
.sc-container.sc-dark .sc-code-body {
847
-
flex: 1;
848
-
overflow-y: auto;
849
-
padding: 1.5rem 0;
850
-
font-family: 'JetBrains Mono', monospace;
851
-
font-size: 0.8rem;
852
-
line-height: 1.75;
853
-
color: var(--sc-code-text);
854
-
}
855
-
856
-
.sc-container.sc-dark .sc-line {
857
-
padding: 0 1.5rem;
858
-
white-space: pre;
859
-
transition: opacity 0.3s ease, background 0.3s ease;
860
-
opacity: 0.25;
861
-
}
862
-
863
-
.sc-container.sc-dark .sc-line.sc-focused {
864
-
opacity: 1;
865
-
background: rgba(74, 222, 128, 0.04);
866
-
border-left: 2px solid var(--sc-accent);
867
-
padding-left: calc(1.5rem - 2px);
868
-
}
869
-
870
-
.sc-container.sc-dark .sc-line-number {
871
-
display: inline-block;
872
-
width: 3ch;
873
-
text-align: right;
874
-
margin-right: 2ch;
875
-
color: var(--sc-code-gutter);
876
-
user-select: none;
877
-
}
878
-
879
-
/* Syntax highlighting — neon palette */
880
-
.sc-container.sc-dark .hl-keyword { color: #ff7eb3; font-weight: 500; }
881
-
.sc-container.sc-dark .hl-type { color: #7dd3fc; }
882
-
.sc-container.sc-dark .hl-string { color: #4ade80; }
883
-
.sc-container.sc-dark .hl-comment { color: #4a4a62; font-style: italic; }
884
-
.sc-container.sc-dark .hl-number { color: #fbbf24; }
885
-
.sc-container.sc-dark .hl-module { color: #c4b5fd; }
886
-
.sc-container.sc-dark .hl-operator { color: #67e8f9; }
887
-
.sc-container.sc-dark .hl-punct { color: #4a4a62; }
888
-
889
-
/* Progress pips */
890
-
.sc-container.sc-dark .sc-progress {
891
-
position: fixed;
892
-
right: 1.5rem;
893
-
top: 50%;
894
-
transform: translateY(-50%);
895
-
display: flex;
896
-
flex-direction: column;
897
-
gap: 10px;
898
-
z-index: 100;
899
-
}
900
-
901
-
.sc-container.sc-dark .sc-pip {
902
-
width: 3px;
903
-
height: 20px;
904
-
border-radius: 2px;
905
-
background: var(--sc-border);
906
-
transition: all 0.3s ease;
907
-
}
908
-
909
-
.sc-container.sc-dark .sc-pip.sc-active {
910
-
background: var(--sc-accent);
911
-
box-shadow: 0 0 12px rgba(74, 222, 128, 0.5);
912
-
height: 30px;
913
-
}
914
-
915
-
/* Animations */
916
-
.sc-container.sc-dark .sc-line.sc-exiting {
917
-
animation: sc-line-exit 0.2s cubic-bezier(0.22, 1, 0.36, 1) forwards;
918
-
}
919
-
920
-
.sc-container.sc-dark .sc-line.sc-entering {
921
-
animation: sc-line-enter 0.25s cubic-bezier(0.22, 1, 0.36, 1) both;
922
-
}
923
-
924
-
.sc-code-slot { display: none; }
925
-
|}
926
-
927
-
(** {1 Theme: Notebook}
928
-
929
-
Clean editorial. Soft white, blue-violet accent.
930
-
Newsreader display + DM Sans body.
931
-
Vertical layout with code blocks inline but sticky. *)
932
-
933
-
let notebook_css =
934
-
{|
935
-
.sc-container.sc-notebook {
936
-
--sc-bg: #fafbfe;
937
-
--sc-text: #1a1a2e;
938
-
--sc-text-dim: #64648a;
939
-
--sc-accent: #6366f1;
940
-
--sc-accent-soft: rgba(99, 102, 241, 0.06);
941
-
--sc-code-bg: #1e1e32;
942
-
--sc-code-text: #d1d0e0;
943
-
--sc-code-gutter: #3a3a52;
944
-
--sc-border: rgba(99, 102, 241, 0.08);
945
-
--sc-panel-radius: 16px;
946
-
font-family: 'DM Sans', sans-serif;
947
-
}
948
-
949
-
.sc-container.sc-notebook .sc-hero {
950
-
background: var(--sc-bg);
951
-
text-align: left;
952
-
padding: 6rem 0 3rem;
953
-
max-width: 640px;
954
-
margin: 0 auto;
955
-
border-bottom: 2px solid var(--sc-accent);
956
-
position: relative;
957
-
}
958
-
959
-
.sc-container.sc-notebook .sc-hero::after {
960
-
content: '';
961
-
position: absolute;
962
-
bottom: -2px;
963
-
left: 0;
964
-
width: 120px;
965
-
height: 2px;
966
-
background: var(--sc-accent);
967
-
box-shadow: 0 0 16px rgba(99, 102, 241, 0.4);
968
-
}
969
-
970
-
.sc-container.sc-notebook .sc-hero h1 {
971
-
font-family: 'Newsreader', serif;
972
-
font-size: clamp(2rem, 4vw, 2.8rem);
973
-
font-weight: 600;
974
-
color: var(--sc-text);
975
-
letter-spacing: -0.02em;
976
-
line-height: 1.15;
977
-
margin-bottom: 0.75rem;
978
-
}
979
-
980
-
.sc-container.sc-notebook .sc-hero p {
981
-
color: var(--sc-text-dim);
982
-
font-size: 1rem;
983
-
max-width: 52ch;
984
-
line-height: 1.6;
985
-
font-weight: 400;
986
-
}
987
-
988
-
.sc-container.sc-notebook .sc-tutorial {
989
-
display: flex;
990
-
gap: 0;
991
-
background: var(--sc-bg);
992
-
max-width: 1200px;
993
-
margin: 0 auto;
994
-
position: relative;
995
-
}
996
-
997
-
.sc-container.sc-notebook .sc-steps-col {
998
-
flex: 1;
999
-
min-width: 0;
1000
-
padding: 2rem 3rem 50vh 0;
1001
-
max-width: 420px;
1002
-
}
1003
-
1004
-
.sc-container.sc-notebook .sc-code-col {
1005
-
flex: 1;
1006
-
min-width: 0;
1007
-
}
1008
-
1009
-
.sc-container.sc-notebook .sc-step {
1010
-
min-height: 60vh;
1011
-
display: flex;
1012
-
flex-direction: column;
1013
-
justify-content: center;
1014
-
padding: 1.5rem 0;
1015
-
position: relative;
1016
-
}
1017
-
1018
-
.sc-container.sc-notebook .sc-step::before {
1019
-
content: '';
1020
-
position: absolute;
1021
-
left: -1.5rem;
1022
-
top: 50%;
1023
-
transform: translateY(-50%);
1024
-
width: 3px;
1025
-
height: 0;
1026
-
background: var(--sc-accent);
1027
-
border-radius: 2px;
1028
-
transition: height 0.4s cubic-bezier(0.22, 1, 0.36, 1);
1029
-
}
1030
-
1031
-
.sc-container.sc-notebook .sc-step-number {
1032
-
font-family: 'DM Sans', sans-serif;
1033
-
font-size: 0.68rem;
1034
-
font-weight: 700;
1035
-
letter-spacing: 0.12em;
1036
-
color: var(--sc-accent);
1037
-
text-transform: uppercase;
1038
-
margin-bottom: 0.5rem;
1039
-
display: flex;
1040
-
align-items: center;
1041
-
gap: 0.5rem;
1042
-
}
1043
-
1044
-
.sc-container.sc-notebook .sc-step h2 {
1045
-
font-family: 'Newsreader', serif;
1046
-
font-size: 1.3rem;
1047
-
font-weight: 600;
1048
-
color: var(--sc-text);
1049
-
letter-spacing: -0.01em;
1050
-
margin-bottom: 0.6rem;
1051
-
line-height: 1.3;
1052
-
}
1053
-
1054
-
.sc-container.sc-notebook .sc-step p {
1055
-
color: var(--sc-text-dim);
1056
-
font-size: 0.88rem;
1057
-
line-height: 1.7;
1058
-
max-width: 42ch;
1059
-
}
1060
-
1061
-
.sc-container.sc-notebook .sc-code-panel {
1062
-
position: sticky;
1063
-
top: 8vh;
1064
-
height: 84vh;
1065
-
margin: 0 0 0 2rem;
1066
-
background: var(--sc-code-bg);
1067
-
border-radius: var(--sc-panel-radius);
1068
-
overflow: hidden;
1069
-
display: flex;
1070
-
flex-direction: column;
1071
-
box-shadow:
1072
-
0 24px 80px rgba(30, 30, 50, 0.15),
1073
-
0 0 0 1px rgba(99, 102, 241, 0.08);
1074
-
}
1075
-
1076
-
.sc-container.sc-notebook .sc-code-header {
1077
-
display: flex;
1078
-
align-items: center;
1079
-
padding: 0.75rem 1.25rem;
1080
-
background: rgba(99, 102, 241, 0.04);
1081
-
border-bottom: 1px solid rgba(255,255,255,0.04);
1082
-
gap: 0.75rem;
1083
-
}
1084
-
1085
-
.sc-container.sc-notebook .sc-dots {
1086
-
display: flex;
1087
-
gap: 5px;
1088
-
}
1089
-
1090
-
.sc-container.sc-notebook .sc-dots span {
1091
-
width: 9px;
1092
-
height: 9px;
1093
-
border-radius: 50%;
1094
-
background: rgba(255,255,255,0.08);
1095
-
}
1096
-
1097
-
.sc-container.sc-notebook .sc-filename {
1098
-
font-family: 'DM Mono', monospace;
1099
-
font-size: 0.7rem;
1100
-
color: rgba(255,255,255,0.3);
1101
-
letter-spacing: 0.04em;
1102
-
flex: 1;
1103
-
text-align: center;
1104
-
}
1105
-
1106
-
.sc-container.sc-notebook .sc-step-badge {
1107
-
font-family: 'DM Mono', monospace;
1108
-
font-size: 0.6rem;
1109
-
color: var(--sc-accent);
1110
-
letter-spacing: 0.06em;
1111
-
}
1112
-
1113
-
.sc-container.sc-notebook .sc-code-body {
1114
-
flex: 1;
1115
-
overflow-y: auto;
1116
-
padding: 1.25rem 0;
1117
-
font-family: 'DM Mono', 'Source Code Pro', monospace;
1118
-
font-size: 0.78rem;
1119
-
line-height: 1.75;
1120
-
color: var(--sc-code-text);
1121
-
}
1122
-
1123
-
.sc-container.sc-notebook .sc-line {
1124
-
padding: 0 1.25rem;
1125
-
white-space: pre;
1126
-
transition: opacity 0.3s ease;
1127
-
opacity: 0.3;
1128
-
}
1129
-
1130
-
.sc-container.sc-notebook .sc-line.sc-focused {
1131
-
opacity: 1;
1132
-
background: rgba(99, 102, 241, 0.05);
1133
-
}
1134
-
1135
-
.sc-container.sc-notebook .sc-line-number {
1136
-
display: inline-block;
1137
-
width: 3ch;
1138
-
text-align: right;
1139
-
margin-right: 1.5ch;
1140
-
color: var(--sc-code-gutter);
1141
-
user-select: none;
1142
-
}
1143
-
1144
-
/* Syntax highlighting — cool tones */
1145
-
.sc-container.sc-notebook .hl-keyword { color: #a78bfa; font-weight: 500; }
1146
-
.sc-container.sc-notebook .hl-type { color: #67e8f9; }
1147
-
.sc-container.sc-notebook .hl-string { color: #86efac; }
1148
-
.sc-container.sc-notebook .hl-comment { color: #4a4a62; font-style: italic; }
1149
-
.sc-container.sc-notebook .hl-number { color: #fde68a; }
1150
-
.sc-container.sc-notebook .hl-module { color: #f9a8d4; }
1151
-
.sc-container.sc-notebook .hl-operator { color: #93c5fd; }
1152
-
.sc-container.sc-notebook .hl-punct { color: #4a4a62; }
1153
-
1154
-
/* Progress pips */
1155
-
.sc-container.sc-notebook .sc-progress {
1156
-
position: fixed;
1157
-
left: 2rem;
1158
-
top: 50%;
1159
-
transform: translateY(-50%);
1160
-
display: flex;
1161
-
flex-direction: column;
1162
-
gap: 6px;
1163
-
z-index: 100;
1164
-
}
1165
-
1166
-
.sc-container.sc-notebook .sc-pip {
1167
-
width: 8px;
1168
-
height: 8px;
1169
-
border-radius: 3px;
1170
-
background: var(--sc-border);
1171
-
transition: all 0.3s ease;
1172
-
}
1173
-
1174
-
.sc-container.sc-notebook .sc-pip.sc-active {
1175
-
background: var(--sc-accent);
1176
-
box-shadow: 0 0 10px rgba(99, 102, 241, 0.4);
1177
-
border-radius: 2px;
1178
-
width: 8px;
1179
-
height: 16px;
1180
-
}
1181
-
1182
-
/* Animations */
1183
-
.sc-container.sc-notebook .sc-line.sc-exiting {
1184
-
animation: sc-line-exit 0.2s cubic-bezier(0.22, 1, 0.36, 1) forwards;
1185
-
}
1186
-
1187
-
.sc-container.sc-notebook .sc-line.sc-entering {
1188
-
animation: sc-line-enter 0.25s cubic-bezier(0.22, 1, 0.36, 1) both;
1189
-
}
1190
-
1191
-
.sc-code-slot { display: none; }
1192
-
|}
1193
-
1194
-
(** {1 CSS to hide odoc chrome}
1195
-
1196
-
When a scrollycode block is rendered, we want it to take over
1197
-
the page. This CSS hides the odoc navigation, breadcrumbs, etc. *)
1198
-
1199
-
let chrome_override_css =
1200
-
{|
1201
-
/* Override odoc page chrome for scrollycode pages */
1202
-
.odoc-nav, .odoc-tocs, .odoc-search { display: none !important; }
1203
-
.odoc-preamble > h1, .odoc-preamble > h2, .odoc-preamble > h3 { display: none !important; }
1204
-
.at-tags > li > .at-tag { display: none !important; }
1205
-
.odoc-preamble, .odoc-content {
1206
-
max-width: none !important;
1207
-
padding: 0 !important;
1208
-
margin: 0 !important;
1209
-
display: block !important;
1210
-
}
1211
-
.at-tags {
1212
-
list-style: none !important;
1213
-
padding: 0 !important;
1214
-
margin: 0 !important;
1215
-
}
1216
-
.at-tags > li {
1217
-
display: block !important;
1218
-
margin: 0 !important;
1219
-
padding: 0 !important;
1220
-
}
1221
-
body.odoc, .odoc {
1222
-
padding: 0 !important;
1223
-
margin: 0 !important;
1224
-
max-width: none !important;
1225
-
background: inherit;
1226
-
}
1227
-
|}
1228
-
1229
-
(** {1 Google Fonts links} *)
1230
-
1231
-
let warm_fonts =
1232
-
{|<link rel="preconnect" href="https://fonts.googleapis.com">
1233
-
<link rel="preconnect" href="https://fonts.gstatic.com" crossorigin>
1234
-
<link href="https://fonts.googleapis.com/css2?family=Fraunces:ital,opsz,wght@0,9..144,300..900;1,9..144,300..900&family=Source+Code+Pro:ital,wght@0,300..900;1,300..900&family=Source+Serif+4:ital,opsz,wght@0,8..60,300..900;1,8..60,300..900&display=swap" rel="stylesheet">|}
1235
-
1236
-
let dark_fonts =
1237
-
{|<link rel="preconnect" href="https://fonts.googleapis.com">
1238
-
<link rel="preconnect" href="https://fonts.gstatic.com" crossorigin>
1239
-
<link href="https://fonts.googleapis.com/css2?family=JetBrains+Mono:wght@300..800&family=Outfit:wght@300..900&display=swap" rel="stylesheet">|}
1240
-
1241
-
let notebook_fonts =
1242
-
{|<link rel="preconnect" href="https://fonts.googleapis.com">
1243
-
<link rel="preconnect" href="https://fonts.gstatic.com" crossorigin>
1244
-
<link href="https://fonts.googleapis.com/css2?family=DM+Mono:wght@300;400;500&family=DM+Sans:ital,opsz,wght@0,9..40,300..900;1,9..40,300..900&family=Newsreader:ital,opsz,wght@0,6..72,300..800;1,6..72,300..800&display=swap" rel="stylesheet">|}
1245
-
1246
-
(** {1 HTML Generation} *)
1247
-
1248
-
(** Generate the code lines HTML for a step's code slot *)
1249
-
let generate_code_lines code focus =
1250
-
let lines = String.split_on_char '\n' code in
1251
-
let buf = Buffer.create 1024 in
1252
-
List.iteri
1253
-
(fun i line ->
1254
-
let line_num = i + 1 in
1255
-
let focused = focus = [] || List.mem line_num focus in
1256
-
let highlighted = highlight_ocaml line in
1257
-
Buffer.add_string buf
1258
-
(Printf.sprintf
1259
-
"<div class=\"sc-line%s\" data-id=\"L%d\">%s</div>\n"
1260
-
(if focused then " sc-focused" else "")
1261
-
line_num highlighted))
1262
-
lines;
1263
-
Buffer.contents buf
1264
-
1265
-
(** Generate the full scrollycode HTML for a given theme *)
1266
-
let generate_html ~theme ~title ~filename steps =
1267
-
let theme_class, fonts, css =
1268
-
match theme with
1269
-
| "warm" -> ("sc-warm", warm_fonts, warm_css)
1270
-
| "dark" -> ("sc-dark", dark_fonts, dark_css)
1271
-
| "notebook" -> ("sc-notebook", notebook_fonts, notebook_css)
1272
-
| _ -> ("sc-warm", warm_fonts, warm_css)
1273
-
in
1274
-
let buf = Buffer.create 16384 in
1275
-
1276
-
(* Fonts *)
1277
-
Buffer.add_string buf fonts;
1278
-
Buffer.add_char buf '\n';
1279
-
1280
-
(* CSS *)
1281
-
Buffer.add_string buf "<style>\n";
1282
-
Buffer.add_string buf chrome_override_css;
1283
-
Buffer.add_string buf css;
1284
-
Buffer.add_string buf "</style>\n";
1285
-
1286
-
(* Container *)
1287
-
Buffer.add_string buf
1288
-
(Printf.sprintf "<div class=\"sc-container %s\">\n" theme_class);
1289
-
1290
-
(* Hero *)
1291
-
Buffer.add_string buf "<div class=\"sc-hero\">\n";
1292
-
Buffer.add_string buf
1293
-
(Printf.sprintf " <h1>%s</h1>\n" (html_escape title));
1294
-
Buffer.add_string buf "</div>\n";
1295
-
1296
-
(* Progress pips *)
1297
-
Buffer.add_string buf "<nav class=\"sc-progress\">\n";
1298
-
List.iteri
1299
-
(fun i _step ->
1300
-
Buffer.add_string buf
1301
-
(Printf.sprintf " <div class=\"sc-pip%s\"></div>\n"
1302
-
(if i = 0 then " sc-active" else "")))
1303
-
steps;
1304
-
Buffer.add_string buf "</nav>\n";
1305
-
1306
-
(* Tutorial layout *)
1307
-
Buffer.add_string buf "<div class=\"sc-tutorial\">\n";
1308
-
1309
-
(* Steps column *)
1310
-
Buffer.add_string buf " <div class=\"sc-steps-col\">\n";
1311
-
List.iteri
1312
-
(fun i step ->
1313
-
Buffer.add_string buf
1314
-
(Printf.sprintf
1315
-
" <div class=\"sc-step\" data-step-index=\"%d\">\n" i);
1316
-
Buffer.add_string buf
1317
-
(Printf.sprintf
1318
-
" <div class=\"sc-step-number\">Step %02d</div>\n" (i + 1));
1319
-
if step.title <> "" then
1320
-
Buffer.add_string buf
1321
-
(Printf.sprintf " <h2>%s</h2>\n" (html_escape step.title));
1322
-
if step.prose <> "" then
1323
-
Buffer.add_string buf
1324
-
(Printf.sprintf " <p>%s</p>\n" (html_escape step.prose));
1325
-
(* Hidden code slot for JS to read *)
1326
-
Buffer.add_string buf " <div class=\"sc-code-slot\">\n";
1327
-
Buffer.add_string buf (generate_code_lines step.code step.focus);
1328
-
Buffer.add_string buf " </div>\n";
1329
-
Buffer.add_string buf " </div>\n")
1330
-
steps;
1331
-
Buffer.add_string buf " </div>\n";
1332
-
1333
-
(* Code column *)
1334
-
Buffer.add_string buf " <div class=\"sc-code-col\">\n";
1335
-
Buffer.add_string buf " <div class=\"sc-code-panel\">\n";
1336
-
Buffer.add_string buf " <div class=\"sc-code-header\">\n";
1337
-
Buffer.add_string buf
1338
-
" <div class=\"sc-dots\"><span></span><span></span><span></span></div>\n";
1339
-
Buffer.add_string buf
1340
-
(Printf.sprintf " <span class=\"sc-filename\">%s</span>\n"
1341
-
(html_escape filename));
1342
-
Buffer.add_string buf
1343
-
(Printf.sprintf
1344
-
" <span class=\"sc-step-badge\">1 / %d</span>\n"
1345
-
(List.length steps));
1346
-
Buffer.add_string buf " </div>\n";
1347
-
Buffer.add_string buf " <div class=\"sc-code-body\">\n";
1348
-
(* Initial code from first step *)
1349
-
(match steps with
1350
-
| first :: _ -> Buffer.add_string buf (generate_code_lines first.code first.focus)
1351
-
| [] -> ());
1352
-
Buffer.add_string buf " </div>\n";
1353
-
Buffer.add_string buf " </div>\n";
1354
-
Buffer.add_string buf " </div>\n";
1355
-
1356
-
Buffer.add_string buf "</div>\n";
1357
-
1358
-
(* JavaScript *)
1359
-
Buffer.add_string buf "<script>\n";
1360
-
Buffer.add_string buf shared_js;
1361
-
Buffer.add_string buf "</script>\n";
1362
-
1363
-
Buffer.contents buf
1364
-
1365
-
(** {1 Extension Registration} *)
1366
-
1367
-
module Scrolly : Odoc_extension_api.Extension = struct
1368
-
let prefix = "scrolly"
1369
-
1370
-
let to_document ~tag content =
1371
-
(* Extract theme from tag: scrolly.warm, scrolly.dark, scrolly.notebook *)
1372
-
let theme =
1373
-
match String.index_opt tag '.' with
1374
-
| None -> "warm"
1375
-
| Some i -> String.sub tag (i + 1) (String.length tag - i - 1)
1376
-
in
1377
-
let tutorial_title, steps = extract_steps content in
1378
-
let filename =
1379
-
match theme with
1380
-
| "dark" -> "main.ml"
1381
-
| "notebook" -> "test.ml"
1382
-
| _ -> "parser.ml"
1383
-
in
1384
-
let html = generate_html ~theme ~title:tutorial_title ~filename steps in
1385
-
let block : Block.t =
1386
-
[
1387
-
{
1388
-
Odoc_document.Types.Block.attr = [ "scrollycode" ];
1389
-
desc = Raw_markup ("html", html);
1390
-
};
1391
-
]
1392
-
in
1393
-
{ Odoc_extension_api.content = block; overrides = []; resources = []; assets = [] }
1394
-
end
1395
-
1396
-
let () = Odoc_extension_api.Registry.register (module Scrolly)
-412
test/scrollycode-demos/dark_repl.mld
-412
test/scrollycode-demos/dark_repl.mld
···
1
-
{0 Building a REPL}
2
-
3
-
@scrolly.dark Building a REPL in OCaml
4
-
{ol
5
-
{li
6
-
{b The Expression Type}
7
-
8
-
A REPL evaluates expressions. We start with a tiny language:
9
-
integer literals, addition, let-bindings, and variables.
10
-
Four constructors is all we need.
11
-
12
-
{[
13
-
type expr =
14
-
| Lit of int
15
-
| Add of expr * expr
16
-
| Let of string * expr * expr
17
-
| Var of string
18
-
]}
19
-
}
20
-
{li
21
-
{b Values and Environments}
22
-
23
-
Evaluation produces values. For now, just integers. An
24
-
environment maps variable names to their values using a
25
-
simple association list.
26
-
27
-
{[
28
-
type expr =
29
-
| Lit of int
30
-
| Add of expr * expr
31
-
| Let of string * expr * expr
32
-
| Var of string
33
-
34
-
type value = Int of int
35
-
36
-
type env = (string * value) list
37
-
38
-
let empty_env : env = []
39
-
40
-
let extend env name v = (name, v) :: env
41
-
42
-
let lookup env name =
43
-
match List.assoc_opt name env with
44
-
| Some v -> v
45
-
| None -> failwith ("unbound: " ^ name)
46
-
]}
47
-
}
48
-
{li
49
-
{b The Evaluator}
50
-
51
-
Pattern matching makes the evaluator beautifully direct.
52
-
Each expression form maps to a straightforward computation.
53
-
Let-bindings extend the environment for the body expression.
54
-
55
-
{[
56
-
type expr =
57
-
| Lit of int
58
-
| Add of expr * expr
59
-
| Let of string * expr * expr
60
-
| Var of string
61
-
62
-
type value = Int of int
63
-
64
-
type env = (string * value) list
65
-
66
-
let empty_env : env = []
67
-
68
-
let extend env name v = (name, v) :: env
69
-
70
-
let lookup env name =
71
-
match List.assoc_opt name env with
72
-
| Some v -> v
73
-
| None -> failwith ("unbound: " ^ name)
74
-
75
-
let rec eval env = function
76
-
| Lit n -> Int n
77
-
| Add (a, b) ->
78
-
let (Int x) = eval env a in
79
-
let (Int y) = eval env b in
80
-
Int (x + y)
81
-
| Let (name, rhs, body) ->
82
-
let v = eval env rhs in
83
-
eval (extend env name v) body
84
-
| Var name -> lookup env name
85
-
]}
86
-
}
87
-
{li
88
-
{b A Tiny Tokenizer}
89
-
90
-
To read user input, we need a tokenizer. It splits a string
91
-
into meaningful chunks: numbers, identifiers, operators, and
92
-
parentheses. Whitespace is consumed but not produced.
93
-
94
-
{[
95
-
type expr =
96
-
| Lit of int
97
-
| Add of expr * expr
98
-
| Let of string * expr * expr
99
-
| Var of string
100
-
101
-
type value = Int of int
102
-
type env = (string * value) list
103
-
let empty_env : env = []
104
-
let extend env name v = (name, v) :: env
105
-
let lookup env name =
106
-
match List.assoc_opt name env with
107
-
| Some v -> v
108
-
| None -> failwith ("unbound: " ^ name)
109
-
110
-
let rec eval env = function
111
-
| Lit n -> Int n
112
-
| Add (a, b) ->
113
-
let (Int x) = eval env a in
114
-
let (Int y) = eval env b in
115
-
Int (x + y)
116
-
| Let (name, rhs, body) ->
117
-
let v = eval env rhs in
118
-
eval (extend env name v) body
119
-
| Var name -> lookup env name
120
-
121
-
type token =
122
-
| TNum of int
123
-
| TIdent of string
124
-
| TPlus | TEqual
125
-
| TLParen | TRParen
126
-
| TLet | TIn
127
-
128
-
let is_alpha c =
129
-
(c >= 'a' && c <= 'z')
130
-
|| (c >= 'A' && c <= 'Z')
131
-
|| c = '_'
132
-
133
-
let is_digit c = c >= '0' && c <= '9'
134
-
135
-
let tokenize input =
136
-
let len = String.length input in
137
-
let pos = ref 0 in
138
-
let tokens = ref [] in
139
-
while !pos < len do
140
-
let c = input.[!pos] in
141
-
if c = ' ' || c = '\t' || c = '\n' then
142
-
incr pos
143
-
else if is_digit c then begin
144
-
let start = !pos in
145
-
while !pos < len && is_digit input.[!pos] do
146
-
incr pos done;
147
-
let s = String.sub input start (!pos - start) in
148
-
tokens := TNum (int_of_string s) :: !tokens
149
-
end else if is_alpha c then begin
150
-
let start = !pos in
151
-
while !pos < len && is_alpha input.[!pos] do
152
-
incr pos done;
153
-
let s = String.sub input start (!pos - start) in
154
-
let tok = match s with
155
-
| "let" -> TLet | "in" -> TIn
156
-
| _ -> TIdent s in
157
-
tokens := tok :: !tokens
158
-
end else begin
159
-
let tok = match c with
160
-
| '+' -> TPlus | '=' -> TEqual
161
-
| '(' -> TLParen | ')' -> TRParen
162
-
| _ -> failwith "unexpected char" in
163
-
tokens := tok :: !tokens;
164
-
incr pos
165
-
end
166
-
done;
167
-
List.rev !tokens
168
-
]}
169
-
}
170
-
{li
171
-
{b The Parser}
172
-
173
-
A recursive descent parser turns tokens into our expression AST.
174
-
It handles operator precedence naturally: addition is parsed as
175
-
a left-associative chain of atoms.
176
-
177
-
{[
178
-
type expr =
179
-
| Lit of int
180
-
| Add of expr * expr
181
-
| Let of string * expr * expr
182
-
| Var of string
183
-
184
-
type value = Int of int
185
-
type env = (string * value) list
186
-
let empty_env : env = []
187
-
let extend env name v = (name, v) :: env
188
-
let lookup env name =
189
-
match List.assoc_opt name env with
190
-
| Some v -> v
191
-
| None -> failwith ("unbound: " ^ name)
192
-
193
-
let rec eval env = function
194
-
| Lit n -> Int n
195
-
| Add (a, b) ->
196
-
let (Int x) = eval env a in
197
-
let (Int y) = eval env b in
198
-
Int (x + y)
199
-
| Let (name, rhs, body) ->
200
-
let v = eval env rhs in
201
-
eval (extend env name v) body
202
-
| Var name -> lookup env name
203
-
204
-
type token =
205
-
| TNum of int | TIdent of string
206
-
| TPlus | TEqual
207
-
| TLParen | TRParen
208
-
| TLet | TIn
209
-
210
-
let is_alpha c =
211
-
(c >= 'a' && c <= 'z')
212
-
|| (c >= 'A' && c <= 'Z') || c = '_'
213
-
let is_digit c = c >= '0' && c <= '9'
214
-
215
-
let tokenize input =
216
-
let len = String.length input in
217
-
let pos = ref 0 in
218
-
let tokens = ref [] in
219
-
while !pos < len do
220
-
let c = input.[!pos] in
221
-
if c = ' ' || c = '\t' || c = '\n' then
222
-
incr pos
223
-
else if is_digit c then begin
224
-
let start = !pos in
225
-
while !pos < len && is_digit input.[!pos]
226
-
do incr pos done;
227
-
let s = String.sub input start
228
-
(!pos - start) in
229
-
tokens := TNum (int_of_string s) :: !tokens
230
-
end else if is_alpha c then begin
231
-
let start = !pos in
232
-
while !pos < len && is_alpha input.[!pos]
233
-
do incr pos done;
234
-
let s = String.sub input start
235
-
(!pos - start) in
236
-
let tok = match s with
237
-
| "let" -> TLet | "in" -> TIn
238
-
| _ -> TIdent s in
239
-
tokens := tok :: !tokens
240
-
end else begin
241
-
let tok = match c with
242
-
| '+' -> TPlus | '=' -> TEqual
243
-
| '(' -> TLParen | ')' -> TRParen
244
-
| _ -> failwith "unexpected char" in
245
-
tokens := tok :: !tokens; incr pos
246
-
end
247
-
done;
248
-
List.rev !tokens
249
-
250
-
let parse tokens =
251
-
let toks = ref tokens in
252
-
let next () =
253
-
match !toks with
254
-
| [] -> failwith "unexpected end"
255
-
| t :: rest -> toks := rest; t in
256
-
let peek () =
257
-
match !toks with [] -> None | t :: _ -> Some t in
258
-
let rec parse_expr () =
259
-
let left = parse_atom () in
260
-
parse_add left
261
-
and parse_add left =
262
-
match peek () with
263
-
| Some TPlus ->
264
-
ignore (next ());
265
-
let right = parse_atom () in
266
-
parse_add (Add (left, right))
267
-
| _ -> left
268
-
and parse_atom () =
269
-
match next () with
270
-
| TNum n -> Lit n
271
-
| TIdent s -> Var s
272
-
| TLParen ->
273
-
let e = parse_expr () in
274
-
ignore (next ()); e
275
-
| TLet ->
276
-
let (TIdent name) = next () in
277
-
ignore (next ());
278
-
let rhs = parse_expr () in
279
-
ignore (next ());
280
-
let body = parse_expr () in
281
-
Let (name, rhs, body)
282
-
| _ -> failwith "unexpected token" in
283
-
parse_expr ()
284
-
]}
285
-
}
286
-
{li
287
-
{b The Read-Eval-Print Loop}
288
-
289
-
Now we connect all the pieces. The REPL reads a line,
290
-
tokenizes it, parses the tokens, evaluates the expression,
291
-
and prints the result. A persistent environment accumulates
292
-
bindings across interactions.
293
-
294
-
{[
295
-
type expr =
296
-
| Lit of int
297
-
| Add of expr * expr
298
-
| Let of string * expr * expr
299
-
| Var of string
300
-
301
-
type value = Int of int
302
-
type env = (string * value) list
303
-
let empty_env : env = []
304
-
let extend env name v = (name, v) :: env
305
-
let lookup env name =
306
-
match List.assoc_opt name env with
307
-
| Some v -> v
308
-
| None -> failwith ("unbound: " ^ name)
309
-
310
-
let rec eval env = function
311
-
| Lit n -> Int n
312
-
| Add (a, b) ->
313
-
let (Int x) = eval env a in
314
-
let (Int y) = eval env b in
315
-
Int (x + y)
316
-
| Let (name, rhs, body) ->
317
-
let v = eval env rhs in
318
-
eval (extend env name v) body
319
-
| Var name -> lookup env name
320
-
321
-
type token =
322
-
| TNum of int | TIdent of string
323
-
| TPlus | TEqual
324
-
| TLParen | TRParen
325
-
| TLet | TIn
326
-
327
-
let is_alpha c =
328
-
(c >= 'a' && c <= 'z')
329
-
|| (c >= 'A' && c <= 'Z') || c = '_'
330
-
let is_digit c = c >= '0' && c <= '9'
331
-
332
-
let tokenize input =
333
-
let len = String.length input in
334
-
let pos = ref 0 in
335
-
let tokens = ref [] in
336
-
while !pos < len do
337
-
let c = input.[!pos] in
338
-
if c = ' ' || c = '\t' || c = '\n' then
339
-
incr pos
340
-
else if is_digit c then begin
341
-
let start = !pos in
342
-
while !pos < len && is_digit input.[!pos]
343
-
do incr pos done;
344
-
tokens := TNum (int_of_string
345
-
(String.sub input start
346
-
(!pos - start))) :: !tokens
347
-
end else if is_alpha c then begin
348
-
let start = !pos in
349
-
while !pos < len && is_alpha input.[!pos]
350
-
do incr pos done;
351
-
let s = String.sub input start
352
-
(!pos - start) in
353
-
tokens := (match s with
354
-
| "let" -> TLet | "in" -> TIn
355
-
| _ -> TIdent s) :: !tokens
356
-
end else begin
357
-
tokens := (match c with
358
-
| '+' -> TPlus | '=' -> TEqual
359
-
| '(' -> TLParen | ')' -> TRParen
360
-
| _ -> failwith "unexpected") :: !tokens;
361
-
incr pos
362
-
end
363
-
done; List.rev !tokens
364
-
365
-
let parse tokens =
366
-
let toks = ref tokens in
367
-
let next () = match !toks with
368
-
| [] -> failwith "end"
369
-
| t :: r -> toks := r; t in
370
-
let peek () = match !toks with
371
-
| [] -> None | t :: _ -> Some t in
372
-
let rec expr () =
373
-
let l = atom () in add l
374
-
and add left = match peek () with
375
-
| Some TPlus ->
376
-
ignore (next ());
377
-
add (Add (left, atom ()))
378
-
| _ -> left
379
-
and atom () = match next () with
380
-
| TNum n -> Lit n
381
-
| TIdent s -> Var s
382
-
| TLParen ->
383
-
let e = expr () in
384
-
ignore (next ()); e
385
-
| TLet ->
386
-
let (TIdent name) = next () in
387
-
ignore (next ());
388
-
let rhs = expr () in
389
-
ignore (next ());
390
-
Let (name, rhs, expr ())
391
-
| _ -> failwith "unexpected" in
392
-
expr ()
393
-
394
-
let print_value = function
395
-
| Int n -> Printf.printf "=> %d\n" n
396
-
397
-
let repl () =
398
-
let env = ref empty_env in
399
-
try while true do
400
-
print_string "> ";
401
-
let line = input_line stdin in
402
-
let tokens = tokenize line in
403
-
let ast = parse tokens in
404
-
let result = eval !env ast in
405
-
print_value result
406
-
done with End_of_file ->
407
-
print_endline "Goodbye."
408
-
409
-
let () = repl ()
410
-
]}
411
-
}
412
-
}
-8
test/scrollycode-demos/dune
-8
test/scrollycode-demos/dune
-198
test/scrollycode-demos/index.mld
-198
test/scrollycode-demos/index.mld
···
1
-
{0 Scrollycode Demos}
2
-
3
-
{%html:
4
-
<link rel="preconnect" href="https://fonts.googleapis.com">
5
-
<link rel="preconnect" href="https://fonts.gstatic.com" crossorigin>
6
-
<link href="https://fonts.googleapis.com/css2?family=Fraunces:ital,opsz,wght@0,9..144,300..900;1,9..144,300..900&family=Source+Code+Pro:ital,wght@0,300..900;1,300..900&family=Source+Serif+4:ital,opsz,wght@0,8..60,300..900;1,8..60,300..900&display=swap" rel="stylesheet">
7
-
<style>
8
-
.odoc-nav, .odoc-tocs, .odoc-search { display: none !important; }
9
-
.odoc-preamble > h1 { display: none !important; }
10
-
.odoc-preamble, .odoc-content { max-width: none !important; padding: 0 !important; margin: 0 !important; }
11
-
body.odoc, .odoc { padding: 0 !important; margin: 0 !important; max-width: none !important; }
12
-
13
-
.demos-index {
14
-
font-family: 'Source Serif 4', Georgia, serif;
15
-
background: #f4f0e8;
16
-
min-height: 100vh;
17
-
}
18
-
19
-
.demos-header {
20
-
max-width: 680px;
21
-
margin: 0 auto;
22
-
padding: 6rem 2rem 3rem;
23
-
text-align: center;
24
-
}
25
-
26
-
.demos-header h1 {
27
-
font-family: 'Fraunces', serif;
28
-
font-size: clamp(2rem, 5vw, 3.2rem);
29
-
font-weight: 800;
30
-
line-height: 1.15;
31
-
letter-spacing: -0.02em;
32
-
margin-bottom: 1rem;
33
-
color: #2c2416;
34
-
}
35
-
36
-
.demos-header h1 em {
37
-
font-style: italic;
38
-
color: #c25832;
39
-
}
40
-
41
-
.demos-header p {
42
-
color: #6b5d4d;
43
-
max-width: 50ch;
44
-
margin: 0 auto;
45
-
font-size: 1.05rem;
46
-
line-height: 1.6;
47
-
}
48
-
49
-
.demos-list {
50
-
max-width: 720px;
51
-
margin: 0 auto;
52
-
padding: 1rem 2rem 6rem;
53
-
display: flex;
54
-
flex-direction: column;
55
-
gap: 1.25rem;
56
-
}
57
-
58
-
.demo-card {
59
-
display: block;
60
-
background: #fff;
61
-
border: 1px solid rgba(44,36,22,0.08);
62
-
border-radius: 10px;
63
-
padding: 1.5rem 1.75rem;
64
-
text-decoration: none;
65
-
color: inherit;
66
-
transition: border-color 0.2s ease, box-shadow 0.2s ease, transform 0.15s ease;
67
-
}
68
-
69
-
.demo-card:hover {
70
-
border-color: #c25832;
71
-
box-shadow: 0 4px 20px rgba(194,88,50,0.1);
72
-
transform: translateY(-2px);
73
-
}
74
-
75
-
.demo-card-header {
76
-
display: flex;
77
-
align-items: baseline;
78
-
gap: 0.75rem;
79
-
margin-bottom: 0.5rem;
80
-
}
81
-
82
-
.demo-card-number {
83
-
font-family: 'Source Code Pro', monospace;
84
-
font-size: 0.68rem;
85
-
font-weight: 600;
86
-
letter-spacing: 0.08em;
87
-
color: #c25832;
88
-
flex-shrink: 0;
89
-
}
90
-
91
-
.demo-card h2 {
92
-
font-family: 'Fraunces', serif;
93
-
font-size: 1.2rem;
94
-
font-weight: 700;
95
-
letter-spacing: -0.01em;
96
-
margin: 0;
97
-
}
98
-
99
-
.demo-card p {
100
-
color: #6b5d4d;
101
-
font-size: 0.92rem;
102
-
line-height: 1.6;
103
-
margin: 0.5rem 0;
104
-
}
105
-
106
-
.demo-card .tags {
107
-
display: flex;
108
-
flex-wrap: wrap;
109
-
gap: 0.4rem;
110
-
margin-top: 0.75rem;
111
-
}
112
-
113
-
.tag {
114
-
font-family: 'Source Code Pro', monospace;
115
-
font-size: 0.65rem;
116
-
letter-spacing: 0.04em;
117
-
padding: 0.2em 0.6em;
118
-
border-radius: 4px;
119
-
background: rgba(194,88,50,0.07);
120
-
color: #c25832;
121
-
}
122
-
123
-
.tag.dark {
124
-
background: #1a1a2e;
125
-
color: rgba(255,255,255,0.5);
126
-
}
127
-
128
-
.demos-footer {
129
-
text-align: center;
130
-
padding: 0 2rem 4rem;
131
-
font-family: 'Source Code Pro', monospace;
132
-
font-size: 0.72rem;
133
-
color: #6b5d4d;
134
-
letter-spacing: 0.04em;
135
-
}
136
-
137
-
.demos-footer a {
138
-
color: #c25832;
139
-
text-decoration: none;
140
-
}
141
-
</style>
142
-
143
-
<div class="demos-index">
144
-
145
-
<div class="demos-header">
146
-
<h1>Scrollycoding in <em>OCaml</em></h1>
147
-
<p>Three odoc extension plugins, each rendering the same scrollycode pattern with a radically different visual theme. Authored as <code>.mld</code> files using <code>@scrolly.<theme></code> custom tags.</p>
148
-
</div>
149
-
150
-
<div class="demos-list">
151
-
152
-
<a class="demo-card" href="warm_parser.html">
153
-
<div class="demo-card-header">
154
-
<span class="demo-card-number">01</span>
155
-
<h2>The Warm Workshop</h2>
156
-
</div>
157
-
<p>Building a JSON parser step by step. Warm cream background with a dark navy code panel, Fraunces serif display type, and earthy burnt-sienna accents. Classic scrollycode split layout.</p>
158
-
<div class="tags">
159
-
<span class="tag">@scrolly.warm</span>
160
-
<span class="tag">Fraunces + Source Serif</span>
161
-
<span class="tag">parser tutorial</span>
162
-
</div>
163
-
</a>
164
-
165
-
<a class="demo-card" href="dark_repl.html">
166
-
<div class="demo-card-header">
167
-
<span class="demo-card-number">02</span>
168
-
<h2>The Dark Terminal</h2>
169
-
</div>
170
-
<p>Building a REPL from scratch. Near-black cinematic theme with phosphor-green accents, JetBrains Mono code font, and the code panel as the visual hero. Prose in a narrow left column.</p>
171
-
<div class="tags">
172
-
<span class="tag dark">@scrolly.dark</span>
173
-
<span class="tag">JetBrains Mono + Outfit</span>
174
-
<span class="tag">REPL tutorial</span>
175
-
</div>
176
-
</a>
177
-
178
-
<a class="demo-card" href="notebook_testing.html">
179
-
<div class="demo-card-header">
180
-
<span class="demo-card-number">03</span>
181
-
<h2>The Notebook</h2>
182
-
</div>
183
-
<p>Building a test framework incrementally. Clean editorial aesthetic with a soft white background, blue-violet accents, Newsreader serif headings, and generous whitespace.</p>
184
-
<div class="tags">
185
-
<span class="tag">@scrolly.notebook</span>
186
-
<span class="tag">Newsreader + DM Sans</span>
187
-
<span class="tag">testing tutorial</span>
188
-
</div>
189
-
</a>
190
-
191
-
</div>
192
-
193
-
<div class="demos-footer">
194
-
Powered by <a href="https://ocaml.github.io/odoc/">odoc</a> custom tag extensions · Inspired by <a href="https://codehike.org">Code Hike</a>
195
-
</div>
196
-
197
-
</div>
198
-
%}
-403
test/scrollycode-demos/notebook_testing.mld
-403
test/scrollycode-demos/notebook_testing.mld
···
1
-
{0 Building a Test Framework}
2
-
3
-
@scrolly.notebook Building a Test Framework in OCaml
4
-
{ol
5
-
{li
6
-
{b A Single Assertion}
7
-
8
-
The simplest possible test: check that a condition holds.
9
-
If it fails, raise an exception with a message. This is
10
-
the foundation everything else builds on.
11
-
12
-
{[
13
-
exception Test_failure of string
14
-
15
-
let assert_equal ~expected ~actual msg =
16
-
if expected <> actual then
17
-
raise (Test_failure
18
-
(Printf.sprintf "%s: expected %s, got %s"
19
-
msg
20
-
(string_of_int expected)
21
-
(string_of_int actual)))
22
-
]}
23
-
}
24
-
{li
25
-
{b Collecting Tests}
26
-
27
-
A test is a named function. We store tests in a mutable list
28
-
so they can be registered declaratively with a simple helper.
29
-
Each test is just a unit function that might raise.
30
-
31
-
{[
32
-
exception Test_failure of string
33
-
34
-
let assert_equal ~expected ~actual msg =
35
-
if expected <> actual then
36
-
raise (Test_failure
37
-
(Printf.sprintf "%s: expected %s, got %s"
38
-
msg
39
-
(string_of_int expected)
40
-
(string_of_int actual)))
41
-
42
-
type test = {
43
-
name : string;
44
-
fn : unit -> unit;
45
-
}
46
-
47
-
let tests : test list ref = ref []
48
-
49
-
let register name fn =
50
-
tests := { name; fn } :: !tests
51
-
52
-
let () = register "addition" (fun () ->
53
-
assert_equal ~expected:4 ~actual:(2 + 2)
54
-
"two plus two")
55
-
56
-
let () = register "multiplication" (fun () ->
57
-
assert_equal ~expected:6 ~actual:(2 * 3)
58
-
"two times three")
59
-
]}
60
-
}
61
-
{li
62
-
{b A Test Runner}
63
-
64
-
The runner iterates through registered tests, catching
65
-
exceptions to report pass or fail. It counts results
66
-
and prints a summary at the end.
67
-
68
-
{[
69
-
exception Test_failure of string
70
-
71
-
let assert_equal ~expected ~actual msg =
72
-
if expected <> actual then
73
-
raise (Test_failure
74
-
(Printf.sprintf "%s: expected %s, got %s"
75
-
msg
76
-
(string_of_int expected)
77
-
(string_of_int actual)))
78
-
79
-
type test = {
80
-
name : string;
81
-
fn : unit -> unit;
82
-
}
83
-
84
-
let tests : test list ref = ref []
85
-
86
-
let register name fn =
87
-
tests := { name; fn } :: !tests
88
-
89
-
type result =
90
-
| Pass
91
-
| Fail of string
92
-
93
-
let run_one test =
94
-
try test.fn (); Pass
95
-
with
96
-
| Test_failure msg -> Fail msg
97
-
| exn -> Fail (Printexc.to_string exn)
98
-
99
-
let run_all () =
100
-
let results =
101
-
List.rev !tests
102
-
|> List.map (fun t -> (t.name, run_one t))
103
-
in
104
-
let passed =
105
-
List.length
106
-
(List.filter
107
-
(fun (_, r) -> r = Pass) results)
108
-
in
109
-
let total = List.length results in
110
-
List.iter (fun (name, result) ->
111
-
match result with
112
-
| Pass ->
113
-
Printf.printf " PASS %s\n" name
114
-
| Fail msg ->
115
-
Printf.printf " FAIL %s: %s\n" name msg
116
-
) results;
117
-
Printf.printf "\n%d/%d tests passed\n"
118
-
passed total;
119
-
if passed < total then exit 1
120
-
]}
121
-
}
122
-
{li
123
-
{b Better Assertions}
124
-
125
-
Real frameworks need more than integer equality. We add
126
-
string comparison, boolean checks, and a generic raises
127
-
assertion that checks an exception is thrown.
128
-
129
-
{[
130
-
exception Test_failure of string
131
-
132
-
let assert_equal ~expected ~actual msg =
133
-
if expected <> actual then
134
-
raise (Test_failure
135
-
(Printf.sprintf "%s: expected %s, got %s"
136
-
msg
137
-
(string_of_int expected)
138
-
(string_of_int actual)))
139
-
140
-
let assert_string_equal ~expected ~actual msg =
141
-
if expected <> actual then
142
-
raise (Test_failure
143
-
(Printf.sprintf
144
-
"%s: expected %S, got %S"
145
-
msg expected actual))
146
-
147
-
let assert_true condition msg =
148
-
if not condition then
149
-
raise (Test_failure msg)
150
-
151
-
let assert_raises fn msg =
152
-
try fn ();
153
-
raise (Test_failure
154
-
(msg ^ ": expected exception"))
155
-
with
156
-
| Test_failure _ as e -> raise e
157
-
| _ -> ()
158
-
159
-
type test = {
160
-
name : string;
161
-
fn : unit -> unit;
162
-
}
163
-
164
-
let tests : test list ref = ref []
165
-
166
-
let register name fn =
167
-
tests := { name; fn } :: !tests
168
-
169
-
type result = Pass | Fail of string
170
-
171
-
let run_one test =
172
-
try test.fn (); Pass
173
-
with
174
-
| Test_failure msg -> Fail msg
175
-
| exn -> Fail (Printexc.to_string exn)
176
-
177
-
let run_all () =
178
-
let results =
179
-
List.rev !tests
180
-
|> List.map (fun t -> (t.name, run_one t))
181
-
in
182
-
let passed = List.length
183
-
(List.filter
184
-
(fun (_, r) -> r = Pass) results) in
185
-
let total = List.length results in
186
-
List.iter (fun (name, result) ->
187
-
match result with
188
-
| Pass ->
189
-
Printf.printf " PASS %s\n" name
190
-
| Fail msg ->
191
-
Printf.printf " FAIL %s: %s\n"
192
-
name msg
193
-
) results;
194
-
Printf.printf "\n%d/%d tests passed\n"
195
-
passed total;
196
-
if passed < total then exit 1
197
-
]}
198
-
}
199
-
{li
200
-
{b Test Suites}
201
-
202
-
As projects grow, tests need organization. We add a suite
203
-
concept that groups related tests under a name. Suites
204
-
can be nested and run independently.
205
-
206
-
{[
207
-
exception Test_failure of string
208
-
209
-
let assert_equal ~expected ~actual msg =
210
-
if expected <> actual then
211
-
raise (Test_failure
212
-
(Printf.sprintf "%s: expected %s, got %s"
213
-
msg
214
-
(string_of_int expected)
215
-
(string_of_int actual)))
216
-
217
-
let assert_string_equal ~expected ~actual msg =
218
-
if expected <> actual then
219
-
raise (Test_failure
220
-
(Printf.sprintf "%s: expected %S, got %S"
221
-
msg expected actual))
222
-
223
-
let assert_true condition msg =
224
-
if not condition then
225
-
raise (Test_failure msg)
226
-
227
-
let assert_raises fn msg =
228
-
try fn ();
229
-
raise (Test_failure
230
-
(msg ^ ": expected exception"))
231
-
with Test_failure _ as e -> raise e | _ -> ()
232
-
233
-
type test = { name : string; fn : unit -> unit }
234
-
type result = Pass | Fail of string
235
-
236
-
type suite = {
237
-
suite_name : string;
238
-
mutable suite_tests : test list;
239
-
}
240
-
241
-
let suites : suite list ref = ref []
242
-
243
-
let create_suite name =
244
-
let s = { suite_name = name;
245
-
suite_tests = [] } in
246
-
suites := s :: !suites; s
247
-
248
-
let add_test suite name fn =
249
-
suite.suite_tests <-
250
-
{ name; fn } :: suite.suite_tests
251
-
252
-
let run_one test =
253
-
try test.fn (); Pass
254
-
with
255
-
| Test_failure msg -> Fail msg
256
-
| exn -> Fail (Printexc.to_string exn)
257
-
258
-
let run_suite suite =
259
-
Printf.printf "Suite: %s\n" suite.suite_name;
260
-
let results =
261
-
List.rev suite.suite_tests
262
-
|> List.map (fun t ->
263
-
(t.name, run_one t)) in
264
-
let passed = List.length
265
-
(List.filter
266
-
(fun (_, r) -> r = Pass) results) in
267
-
let total = List.length results in
268
-
List.iter (fun (name, result) ->
269
-
match result with
270
-
| Pass ->
271
-
Printf.printf " PASS %s\n" name
272
-
| Fail msg ->
273
-
Printf.printf " FAIL %s: %s\n"
274
-
name msg
275
-
) results;
276
-
Printf.printf " %d/%d passed\n\n"
277
-
passed total;
278
-
passed = total
279
-
280
-
let run_all_suites () =
281
-
let all_ok = List.for_all run_suite
282
-
(List.rev !suites) in
283
-
if not all_ok then exit 1
284
-
]}
285
-
}
286
-
{li
287
-
{b Expect Tests}
288
-
289
-
The crown jewel: expect tests capture actual output and
290
-
compare it to an expected snapshot. On first run, they
291
-
record the output. On later runs, they detect regressions.
292
-
This is how tools like ppx_expect and Cram tests work.
293
-
294
-
{[
295
-
exception Test_failure of string
296
-
297
-
let assert_equal ~expected ~actual msg =
298
-
if expected <> actual then
299
-
raise (Test_failure
300
-
(Printf.sprintf "%s: expected %s, got %s"
301
-
msg
302
-
(string_of_int expected)
303
-
(string_of_int actual)))
304
-
305
-
let assert_string_equal ~expected ~actual msg =
306
-
if expected <> actual then
307
-
raise (Test_failure
308
-
(Printf.sprintf "%s: expected %S, got %S"
309
-
msg expected actual))
310
-
311
-
let assert_true condition msg =
312
-
if not condition then
313
-
raise (Test_failure msg)
314
-
315
-
let assert_raises fn msg =
316
-
try fn ();
317
-
raise (Test_failure
318
-
(msg ^ ": expected exception"))
319
-
with Test_failure _ as e -> raise e | _ -> ()
320
-
321
-
type test = { name : string; fn : unit -> unit }
322
-
type result = Pass | Fail of string
323
-
324
-
type suite = {
325
-
suite_name : string;
326
-
mutable suite_tests : test list;
327
-
}
328
-
329
-
let suites : suite list ref = ref []
330
-
331
-
let create_suite name =
332
-
let s = { suite_name = name;
333
-
suite_tests = [] } in
334
-
suites := s :: !suites; s
335
-
336
-
let add_test suite name fn =
337
-
suite.suite_tests <-
338
-
{ name; fn } :: suite.suite_tests
339
-
340
-
let run_one test =
341
-
try test.fn (); Pass
342
-
with
343
-
| Test_failure msg -> Fail msg
344
-
| exn -> Fail (Printexc.to_string exn)
345
-
346
-
(* Expect test infrastructure *)
347
-
let expect_dir = "_expect"
348
-
349
-
let expect_test suite name fn =
350
-
add_test suite name (fun () ->
351
-
let buf = Buffer.create 256 in
352
-
fn (Buffer.add_string buf);
353
-
let actual = Buffer.contents buf in
354
-
let path = Printf.sprintf "%s/%s/%s.expected"
355
-
expect_dir suite.suite_name name in
356
-
if Sys.file_exists path then begin
357
-
let ic = open_in path in
358
-
let expected = really_input_string ic
359
-
(in_channel_length ic) in
360
-
close_in ic;
361
-
assert_string_equal
362
-
~expected ~actual
363
-
(name ^ " snapshot")
364
-
end else begin
365
-
let dir = Filename.dirname path in
366
-
ignore (Sys.command
367
-
("mkdir -p " ^ dir));
368
-
let oc = open_out path in
369
-
output_string oc actual;
370
-
close_out oc;
371
-
Printf.printf
372
-
" NEW %s (snapshot saved)\n" name
373
-
end)
374
-
375
-
let run_suite suite =
376
-
Printf.printf "Suite: %s\n" suite.suite_name;
377
-
let results =
378
-
List.rev suite.suite_tests
379
-
|> List.map (fun t ->
380
-
(t.name, run_one t)) in
381
-
let passed = List.length
382
-
(List.filter
383
-
(fun (_, r) -> r = Pass) results) in
384
-
let total = List.length results in
385
-
List.iter (fun (name, result) ->
386
-
match result with
387
-
| Pass ->
388
-
Printf.printf " PASS %s\n" name
389
-
| Fail msg ->
390
-
Printf.printf " FAIL %s: %s\n"
391
-
name msg
392
-
) results;
393
-
Printf.printf " %d/%d passed\n\n"
394
-
passed total;
395
-
passed = total
396
-
397
-
let run_all_suites () =
398
-
let all_ok = List.for_all run_suite
399
-
(List.rev !suites) in
400
-
if not all_ok then exit 1
401
-
]}
402
-
}
403
-
}
-14
test/scrollycode-demos/odoc_scrolly.ml
-14
test/scrollycode-demos/odoc_scrolly.ml
···
1
-
(* Custom odoc binary with the scrollycode extension statically linked.
2
-
3
-
The scrollycode extension registers itself when this module is loaded,
4
-
via the [let () = ...] at the bottom of scrollycode_extension.ml.
5
-
6
-
We force it to be linked by referencing it, then invoke the standard
7
-
odoc CLI entry point. *)
8
-
9
-
(* Force-link the extension module *)
10
-
let () =
11
-
ignore (Scrollycode_extension.Scrolly.prefix : string)
12
-
13
-
(* Include the full odoc CLI - this is main.ml without the dune-site loading *)
14
-
include Odoc_scrolly_main
-1858
test/scrollycode-demos/odoc_scrolly_main.ml
-1858
test/scrollycode-demos/odoc_scrolly_main.ml
···
1
-
(* CR-someday trefis: the "deps" and "targets" subcommands currently output
2
-
their result on stdout.
3
-
It would make the interaction with jenga nicer if we could specify a file to
4
-
output the result to. *)
5
-
6
-
open Odoc_utils
7
-
open ResultMonad
8
-
module List = ListLabels
9
-
open Odoc_odoc
10
-
open Cmdliner
11
-
12
-
(* Load all installed extensions at startup *)
13
-
14
-
15
-
let convert_syntax : Odoc_document.Renderer.syntax Arg.conv =
16
-
let syntax_parser str =
17
-
match str with
18
-
| "ml" | "ocaml" -> Ok Odoc_document.Renderer.OCaml
19
-
| "re" | "reason" -> Ok Odoc_document.Renderer.Reason
20
-
| s -> Error (Printf.sprintf "Unknown syntax '%s'" s)
21
-
in
22
-
let syntax_printer fmt syntax =
23
-
Format.pp_print_string fmt (Odoc_document.Renderer.string_of_syntax syntax)
24
-
in
25
-
Arg.conv' (syntax_parser, syntax_printer)
26
-
27
-
let convert_directory ?(create = false) () : Fs.Directory.t Arg.conv =
28
-
let dir_parser, dir_printer =
29
-
(Arg.conv_parser Arg.string, Arg.conv_printer Arg.string)
30
-
in
31
-
let odoc_dir_parser str =
32
-
let () = if create then Fs.Directory.(mkdir_p (of_string str)) in
33
-
match dir_parser str with
34
-
| Ok res -> Ok (Fs.Directory.of_string res)
35
-
| Error (`Msg e) -> Error e
36
-
in
37
-
let odoc_dir_printer fmt dir = dir_printer fmt (Fs.Directory.to_string dir) in
38
-
Arg.conv' (odoc_dir_parser, odoc_dir_printer)
39
-
40
-
(** On top of the conversion 'file' that checks that the passed file exists. *)
41
-
let convert_fpath =
42
-
let parse inp =
43
-
match Arg.(conv_parser file) inp with
44
-
| Ok s -> Ok (Fs.File.of_string s)
45
-
| Error _ as e -> e
46
-
and print = Fpath.pp in
47
-
Arg.conv (parse, print)
48
-
49
-
let convert_named_root =
50
-
let parse inp =
51
-
match String.cuts inp ~sep:":" with
52
-
| [ s1; s2 ] -> Ok (s1, Fs.Directory.of_string s2)
53
-
| _ -> Error (`Msg "")
54
-
in
55
-
let print ppf (s, t) =
56
-
Format.fprintf ppf "%s:%s" s (Fs.Directory.to_string t)
57
-
in
58
-
Arg.conv (parse, print)
59
-
60
-
let handle_error = function
61
-
| Ok () -> ()
62
-
| Error (`Cli_error msg) ->
63
-
Printf.eprintf "%s\n%!" msg;
64
-
exit 2
65
-
| Error (`Msg msg) ->
66
-
Printf.eprintf "ERROR: %s\n%!" msg;
67
-
exit 1
68
-
69
-
module Antichain = struct
70
-
let absolute_normalization p =
71
-
let p =
72
-
if Fpath.is_rel p then Fpath.( // ) (Fpath.v (Sys.getcwd ())) p else p
73
-
in
74
-
Fpath.normalize p
75
-
76
-
(** Check that a list of directories form an antichain: they are all disjoints
77
-
*)
78
-
let check ~opt l =
79
-
let l =
80
-
List.map
81
-
~f:(fun p -> p |> Fs.Directory.to_fpath |> absolute_normalization)
82
-
l
83
-
in
84
-
let rec check = function
85
-
| [] -> true
86
-
| p1 :: rest ->
87
-
List.for_all
88
-
~f:(fun p2 ->
89
-
(not (Fpath.is_prefix p1 p2)) && not (Fpath.is_prefix p2 p1))
90
-
rest
91
-
&& check rest
92
-
in
93
-
if check l then Ok ()
94
-
else
95
-
let msg =
96
-
Format.sprintf "Paths given to all %s options must be disjoint" opt
97
-
in
98
-
Error (`Msg msg)
99
-
end
100
-
101
-
let docs = "ARGUMENTS"
102
-
103
-
let odoc_file_directories =
104
-
let doc =
105
-
"Where to look for required $(i,.odoc) files. Can be present several times."
106
-
in
107
-
Arg.(
108
-
value
109
-
& opt_all (convert_directory ()) []
110
-
& info ~docs ~docv:"DIR" ~doc [ "I" ])
111
-
112
-
let hidden =
113
-
let doc =
114
-
"Mark the unit as hidden. (Useful for files included in module packs)."
115
-
in
116
-
Arg.(value & flag & info ~docs ~doc [ "hidden" ])
117
-
118
-
let extra_suffix =
119
-
let doc =
120
-
"Extra suffix to append to generated filenames. This is intended for \
121
-
expect tests to use."
122
-
in
123
-
let default = None in
124
-
Arg.(
125
-
value
126
-
& opt (some string) default
127
-
& info ~docv:"SUFFIX" ~doc [ "extra-suffix" ])
128
-
129
-
let warnings_options =
130
-
let warn_error =
131
-
let doc = "Turn warnings into errors." in
132
-
let env =
133
-
Cmd.Env.info "ODOC_WARN_ERROR" ~doc:(doc ^ " See option $(opt).")
134
-
in
135
-
Arg.(value & flag & info ~docs ~doc ~env [ "warn-error" ])
136
-
in
137
-
let print_warnings =
138
-
let doc =
139
-
"Whether warnings should be printed to stderr. See the $(b,errors) \
140
-
command."
141
-
in
142
-
let env = Cmd.Env.info "ODOC_PRINT_WARNINGS" ~doc in
143
-
Arg.(value & opt bool true & info ~docs ~doc ~env [ "print-warnings" ])
144
-
in
145
-
let enable_missing_root_warning =
146
-
let doc =
147
-
"Produce a warning when a root is missing. This is usually a build \
148
-
system problem so is disabled for users by default."
149
-
in
150
-
let env = Cmd.Env.info "ODOC_ENABLE_MISSING_ROOT_WARNING" ~doc in
151
-
Arg.(value & flag & info ~docs ~doc ~env [ "enable-missing-root-warning" ])
152
-
in
153
-
let warnings_tag =
154
-
let doc =
155
-
"Warnings tag. This is useful when you want to declare that warnings \
156
-
that would be generated resolving the references defined in this unit \
157
-
should be ignored if they end up in expansions in other units. If this \
158
-
option is passed, link-time warnings will be suppressed unless the link \
159
-
command is passed the tag via the --warnings-tags parameter. A suitable \
160
-
tag would be the name of the package."
161
-
in
162
-
let env = Cmd.Env.info "ODOC_WARNINGS_TAG" ~doc in
163
-
Arg.(
164
-
value & opt (some string) None & info ~docs ~doc ~env [ "warnings-tag" ])
165
-
in
166
-
Term.(
167
-
const
168
-
(fun warn_error print_warnings enable_missing_root_warning warnings_tag ->
169
-
Odoc_model.Error.enable_missing_root_warning :=
170
-
enable_missing_root_warning;
171
-
{ Odoc_model.Error.warn_error; print_warnings; warnings_tag })
172
-
$ warn_error $ print_warnings $ enable_missing_root_warning $ warnings_tag)
173
-
174
-
let dst ?create () =
175
-
let doc = "Output directory where the HTML tree is expected to be saved." in
176
-
Arg.(
177
-
required
178
-
& opt (some (convert_directory ?create ())) None
179
-
& info ~docs ~docv:"DIR" ~doc [ "o"; "output-dir" ])
180
-
181
-
let open_modules =
182
-
let doc =
183
-
"Initially open module. Can be used more than once. Defaults to 'Stdlib'"
184
-
in
185
-
let default = [ "Stdlib" ] in
186
-
Arg.(value & opt_all string default & info ~docv:"MODULE" ~doc [ "open" ])
187
-
188
-
module Compile : sig
189
-
val output_file : dst:string option -> input:Fs.file -> Fs.file
190
-
191
-
val input : string Term.t
192
-
193
-
val dst : string option Term.t
194
-
195
-
val cmd : unit Term.t
196
-
197
-
val info : docs:string -> Cmd.info
198
-
end = struct
199
-
let has_page_prefix file =
200
-
file |> Fs.File.basename |> Fs.File.to_string
201
-
|> String.is_prefix ~affix:"page-"
202
-
203
-
let unique_id =
204
-
let doc = "For debugging use" in
205
-
Arg.(value & opt (some string) None & info ~doc ~docv:"ID" [ "unique-id" ])
206
-
207
-
let output_file ~dst ~input =
208
-
match dst with
209
-
| Some file ->
210
-
let output = Fs.File.of_string file in
211
-
if Fs.File.has_ext ".mld" input && not (has_page_prefix output) then (
212
-
Printf.eprintf
213
-
"ERROR: the name of the .odoc file produced from a .mld must start \
214
-
with 'page-'\n\
215
-
%!";
216
-
exit 1);
217
-
output
218
-
| None ->
219
-
let output =
220
-
if Fs.File.has_ext ".mld" input && not (has_page_prefix input) then
221
-
let directory = Fs.File.dirname input in
222
-
let name = Fs.File.basename input in
223
-
let name = "page-" ^ Fs.File.to_string name in
224
-
Fs.File.create ~directory ~name
225
-
else input
226
-
in
227
-
Fs.File.(set_ext ".odoc" output)
228
-
229
-
let compile hidden directories resolve_fwd_refs dst output_dir package_opt
230
-
parent_name_opt parent_id_opt open_modules children input warnings_options
231
-
unique_id short_title =
232
-
let _ =
233
-
match unique_id with
234
-
| Some id -> Odoc_model.Names.set_unique_ident id
235
-
| None -> ()
236
-
in
237
-
let resolver =
238
-
Resolver.create ~important_digests:(not resolve_fwd_refs) ~directories
239
-
~open_modules ~roots:None
240
-
in
241
-
let input = Fs.File.of_string input in
242
-
let output = output_file ~dst ~input in
243
-
let cli_spec =
244
-
let error message = Error (`Cli_error message) in
245
-
match
246
-
(parent_name_opt, package_opt, parent_id_opt, children, output_dir)
247
-
with
248
-
| Some _, None, None, _, None ->
249
-
Ok (Compile.CliParent { parent = parent_name_opt; children; output })
250
-
| None, Some p, None, [], None ->
251
-
Ok (Compile.CliPackage { package = p; output })
252
-
| None, None, Some p, [], Some output_dir ->
253
-
Ok (Compile.CliParentId { parent_id = p; output_dir })
254
-
| None, None, None, _ :: _, None ->
255
-
Ok (Compile.CliParent { parent = None; output; children })
256
-
| None, None, None, [], None -> Ok (Compile.CliNoParent output)
257
-
| Some _, Some _, _, _, _ ->
258
-
error "Either --package or --parent should be specified, not both."
259
-
| _, Some _, Some _, _, _ ->
260
-
error "Either --package or --parent-id should be specified, not both."
261
-
| Some _, _, Some _, _, _ ->
262
-
error "Either --parent or --parent-id should be specified, not both."
263
-
| _, _, None, _, Some _ ->
264
-
error "--output-dir can only be passed with --parent-id."
265
-
| None, Some _, _, _ :: _, _ ->
266
-
error "--child cannot be passed with --package."
267
-
| None, _, Some _, _ :: _, _ ->
268
-
error "--child cannot be passed with --parent-id."
269
-
| _, _, Some _, _, None ->
270
-
error "--output-dir is required when passing --parent-id."
271
-
in
272
-
cli_spec >>= fun cli_spec ->
273
-
Fs.Directory.mkdir_p (Fs.File.dirname output);
274
-
Compile.compile ~resolver ~cli_spec ~hidden ~warnings_options ~short_title
275
-
input
276
-
277
-
let input =
278
-
let doc = "Input $(i,.cmti), $(i,.cmt), $(i,.cmi) or $(i,.mld) file." in
279
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"FILE" [])
280
-
281
-
let dst =
282
-
let doc =
283
-
"Output file path. Non-existing intermediate directories are created. If \
284
-
absent outputs a $(i,BASE.odoc) file in the same directory as the input \
285
-
file where $(i,BASE) is the basename of the input file. For mld files \
286
-
the \"page-\" prefix will be added if not already present in the input \
287
-
basename."
288
-
in
289
-
Arg.(value & opt (some string) None & info ~docs ~docv:"PATH" ~doc [ "o" ])
290
-
291
-
let output_dir =
292
-
let doc = "Output file directory. " in
293
-
Arg.(
294
-
value
295
-
& opt (some string) None
296
-
& info ~docs ~docv:"PATH" ~doc [ "output-dir" ])
297
-
298
-
let children =
299
-
let doc =
300
-
"Specify the $(i,.odoc) file as a child. Can be used multiple times. \
301
-
Only applies to mld files."
302
-
in
303
-
let default = [] in
304
-
Arg.(
305
-
value & opt_all string default & info ~docv:"CHILD" ~doc [ "c"; "child" ])
306
-
307
-
let cmd =
308
-
let package_opt =
309
-
let doc =
310
-
"Package the input is part of. Deprecated: use '--parent' instead."
311
-
in
312
-
Arg.(
313
-
value
314
-
& opt (some string) None
315
-
& info ~docs ~docv:"PKG" ~doc [ "package"; "pkg" ])
316
-
in
317
-
let parent_opt =
318
-
let doc = "Parent page or subpage." in
319
-
Arg.(
320
-
value
321
-
& opt (some string) None
322
-
& info ~docs ~docv:"PARENT" ~doc [ "parent" ])
323
-
in
324
-
let parent_id_opt =
325
-
let doc = "Parent id." in
326
-
Arg.(
327
-
value
328
-
& opt (some string) None
329
-
& info ~docs ~docv:"PARENT" ~doc [ "parent-id" ])
330
-
in
331
-
let short_title =
332
-
let doc = "Override short_title of an mld file" in
333
-
Arg.(
334
-
value
335
-
& opt (some string) None
336
-
& info ~docs ~docv:"TITLE" ~doc [ "short-title" ])
337
-
in
338
-
let resolve_fwd_refs =
339
-
let doc = "Try resolving forward references." in
340
-
Arg.(value & flag & info ~doc [ "r"; "resolve-fwd-refs" ])
341
-
in
342
-
Term.(
343
-
const handle_error
344
-
$ (const compile $ hidden $ odoc_file_directories $ resolve_fwd_refs $ dst
345
-
$ output_dir $ package_opt $ parent_opt $ parent_id_opt $ open_modules
346
-
$ children $ input $ warnings_options $ unique_id $ short_title))
347
-
348
-
let info ~docs =
349
-
let man =
350
-
[
351
-
`S "DEPENDENCIES";
352
-
`P
353
-
"Dependencies between compilation units is the same as while \
354
-
compiling the initial OCaml modules.";
355
-
`P "Mld pages don't have any dependency.";
356
-
]
357
-
in
358
-
let doc =
359
-
"Compile a $(i,.cmti), $(i,.cmt), $(i,.cmi) or $(i,.mld) file to an \
360
-
$(i,.odoc) file."
361
-
in
362
-
Cmd.info "compile" ~docs ~doc ~man
363
-
end
364
-
365
-
module Compile_asset = struct
366
-
let compile_asset parent_id name output_dir =
367
-
Odoc_odoc.Asset.compile ~parent_id ~name ~output_dir
368
-
369
-
let output_dir =
370
-
let doc = "Output file directory. " in
371
-
Arg.(
372
-
required
373
-
& opt (some string) None
374
-
& info ~docs ~docv:"PATH" ~doc [ "output-dir" ])
375
-
376
-
let cmd =
377
-
let asset_name =
378
-
let doc = "Name of the asset." in
379
-
Arg.(
380
-
required
381
-
& opt (some string) None
382
-
& info ~docs ~docv:"NAME" ~doc [ "name" ])
383
-
in
384
-
let parent_id =
385
-
let doc = "Parent id." in
386
-
Arg.(
387
-
required
388
-
& opt (some string) None
389
-
& info ~docs ~docv:"PARENT" ~doc [ "parent-id" ])
390
-
in
391
-
Term.(
392
-
const handle_error
393
-
$ (const compile_asset $ parent_id $ asset_name $ output_dir))
394
-
395
-
let info ~docs =
396
-
let man =
397
-
[
398
-
`S "DEPENDENCIES";
399
-
`P
400
-
"There are no dependency for compile assets, in particular you do \
401
-
not need the asset itself at this stage.";
402
-
]
403
-
in
404
-
let doc = "Declare the name of an asset." in
405
-
Cmd.info "compile-asset" ~docs ~doc ~man
406
-
end
407
-
408
-
module Compile_impl = struct
409
-
let prefix = "impl-"
410
-
411
-
let output_dir =
412
-
let doc = "Output file directory. " in
413
-
Arg.(
414
-
value
415
-
& opt (some string) None
416
-
& info ~docs ~docv:"PATH" ~doc [ "output-dir" ])
417
-
418
-
let output_file output_dir parent_id input =
419
-
let name =
420
-
Fs.File.basename input |> Fpath.set_ext "odoc" |> Fs.File.to_string
421
-
|> String.Ascii.uncapitalize
422
-
in
423
-
let name = prefix ^ name in
424
-
425
-
let dir = Fpath.(append output_dir parent_id) in
426
-
Fs.File.create
427
-
~directory:(Fpath.to_string dir |> Fs.Directory.of_string)
428
-
~name
429
-
430
-
let compile_impl directories output_dir parent_id source_id input
431
-
warnings_options =
432
-
let input = Fs.File.of_string input in
433
-
let output_dir =
434
-
match output_dir with Some x -> Fpath.v x | None -> Fpath.v "."
435
-
in
436
-
let output =
437
-
output_file output_dir
438
-
(match parent_id with Some x -> Fpath.v x | None -> Fpath.v ".")
439
-
input
440
-
in
441
-
let resolver =
442
-
Resolver.create ~important_digests:true ~directories ~open_modules:[]
443
-
~roots:None
444
-
in
445
-
Source.compile ~resolver ~source_id ~output ~warnings_options input
446
-
447
-
let cmd =
448
-
let input =
449
-
let doc = "Input $(i,.cmt) file." in
450
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"FILE" [])
451
-
in
452
-
let source_id =
453
-
let doc = "The id of the source file" in
454
-
Arg.(
455
-
value
456
-
& opt (some string) None
457
-
& info [ "source-id" ] ~doc ~docv:"/path/to/source.ml")
458
-
in
459
-
let parent_id =
460
-
let doc = "The parent id of the implementation" in
461
-
Arg.(
462
-
value
463
-
& opt (some string) None
464
-
& info [ "parent-id" ] ~doc ~docv:"/path/to/library")
465
-
in
466
-
467
-
Term.(
468
-
const handle_error
469
-
$ (const compile_impl $ odoc_file_directories $ output_dir $ parent_id
470
-
$ source_id $ input $ warnings_options))
471
-
472
-
let info ~docs =
473
-
let doc =
474
-
"(EXPERIMENTAL) Compile a $(i,NAME.cmt) file to a $(i,src-NAME.odoc) \
475
-
containing the implementation information needed by odoc for the \
476
-
compilation unit."
477
-
in
478
-
Cmd.info "compile-impl" ~docs ~doc
479
-
end
480
-
481
-
module Indexing = struct
482
-
let output_file ~dst marshall =
483
-
match (dst, marshall) with
484
-
| Some file, `JSON
485
-
when not
486
-
(Fpath.has_ext "json" (Fpath.v file)
487
-
|| Fpath.has_ext "js" (Fpath.v file)) ->
488
-
Error
489
-
(`Msg
490
-
"When generating a json index, the output must have a .json or \
491
-
.js file extension")
492
-
| Some file, `Marshall when not (Fpath.has_ext "odoc-index" (Fpath.v file))
493
-
->
494
-
Error
495
-
(`Msg
496
-
"When generating a binary index, the output must have a \
497
-
.odoc-index file extension")
498
-
| Some file, _ -> Ok (Fs.File.of_string file)
499
-
| None, `JSON -> Ok (Fs.File.of_string "index.json")
500
-
| None, `Marshall -> Ok (Fs.File.of_string "index.odoc-index")
501
-
502
-
let index dst json warnings_options roots inputs_in_file inputs occurrences
503
-
simplified_json wrap_json =
504
-
let marshall = if json then `JSON else `Marshall in
505
-
output_file ~dst marshall >>= fun output ->
506
-
Indexing.compile marshall ~output ~warnings_options ~roots ~occurrences
507
-
~inputs_in_file ~simplified_json ~wrap_json ~odocls:inputs
508
-
509
-
let cmd =
510
-
let dst =
511
-
let doc =
512
-
"Output file path. Non-existing intermediate directories are created. \
513
-
Defaults to index.odoc-index, or index.json if --json is passed (in \
514
-
which case, the .odoc-index file extension is mandatory)."
515
-
in
516
-
Arg.(
517
-
value & opt (some string) None & info ~docs ~docv:"PATH" ~doc [ "o" ])
518
-
in
519
-
let occurrences =
520
-
let doc = "Occurrence file." in
521
-
Arg.(
522
-
value
523
-
& opt (some convert_fpath) None
524
-
& info ~docs ~docv:"PATH" ~doc [ "occurrences" ])
525
-
in
526
-
let inputs_in_file =
527
-
let doc =
528
-
"Input text file containing a line-separated list of paths to .odocl \
529
-
files to index."
530
-
in
531
-
Arg.(
532
-
value & opt_all convert_fpath []
533
-
& info ~doc ~docv:"FILE" [ "file-list" ])
534
-
in
535
-
let json =
536
-
let doc = "whether to output a json file, or a binary .odoc-index file" in
537
-
Arg.(value & flag & info ~doc [ "json" ])
538
-
in
539
-
let simplified_json =
540
-
let doc =
541
-
"whether to simplify the json file. Only has an effect in json output \
542
-
mode."
543
-
in
544
-
Arg.(value & flag & info ~doc [ "simplified-json" ])
545
-
in
546
-
let wrap_json =
547
-
let doc =
548
-
"Not intended for general use. Wraps the json output in a JavaScript \
549
-
variable assignment, and assumes the use of fuse.js"
550
-
in
551
-
Arg.(value & flag & info ~doc [ "wrap-json" ])
552
-
in
553
-
554
-
let inputs =
555
-
let doc = ".odocl file to index" in
556
-
Arg.(value & pos_all convert_fpath [] & info ~doc ~docv:"FILE" [])
557
-
in
558
-
let roots =
559
-
let doc =
560
-
"Specifies a directory PATH containing pages or units that should be \
561
-
included in the sidebar."
562
-
in
563
-
Arg.(
564
-
value
565
-
& opt_all (convert_directory ()) []
566
-
& info ~docs ~docv:"NAME:PATH" ~doc [ "root" ])
567
-
in
568
-
Term.(
569
-
const handle_error
570
-
$ (const index $ dst $ json $ warnings_options $ roots $ inputs_in_file
571
-
$ inputs $ occurrences $ simplified_json $ wrap_json))
572
-
573
-
let info ~docs =
574
-
let doc =
575
-
"Generate an index of all identified entries in the .odocl files found \
576
-
in the given directories."
577
-
in
578
-
Cmd.info "compile-index" ~docs ~doc
579
-
end
580
-
581
-
module Sidebar = struct
582
-
let output_file ~dst marshall =
583
-
match (dst, marshall) with
584
-
| Some file, `JSON when not (Fpath.has_ext "json" (Fpath.v file)) ->
585
-
Error
586
-
(`Msg
587
-
"When generating a sidebar with --json, the output must have a \
588
-
.json file extension")
589
-
| Some file, `Marshall
590
-
when not (Fpath.has_ext "odoc-sidebar" (Fpath.v file)) ->
591
-
Error
592
-
(`Msg
593
-
"When generating sidebar, the output must have a .odoc-sidebar \
594
-
file extension")
595
-
| Some file, _ -> Ok (Fs.File.of_string file)
596
-
| None, `JSON -> Ok (Fs.File.of_string "sidebar.json")
597
-
| None, `Marshall -> Ok (Fs.File.of_string "sidebar.odoc-sidebar")
598
-
599
-
let generate dst json warnings_options input =
600
-
let marshall = if json then `JSON else `Marshall in
601
-
output_file ~dst marshall >>= fun output ->
602
-
Sidebar.generate ~marshall ~output ~warnings_options ~index:input
603
-
604
-
let cmd =
605
-
let dst =
606
-
let doc =
607
-
"Output file path. Non-existing intermediate directories are created. \
608
-
Defaults to sidebar.odoc-sidebar, or sidebar.json if --json is \
609
-
passed."
610
-
in
611
-
Arg.(
612
-
value & opt (some string) None & info ~docs ~docv:"PATH" ~doc [ "o" ])
613
-
in
614
-
let json =
615
-
let doc = "whether to output a json file, or a binary .odoc-index file" in
616
-
Arg.(value & flag & info ~doc [ "json" ])
617
-
in
618
-
let inputs =
619
-
let doc = ".odoc-index file to generate a value from" in
620
-
Arg.(
621
-
required & pos 0 (some convert_fpath) None & info ~doc ~docv:"FILE" [])
622
-
in
623
-
Term.(
624
-
const handle_error
625
-
$ (const generate $ dst $ json $ warnings_options $ inputs))
626
-
627
-
let info ~docs =
628
-
let doc = "Generate a sidebar from an index file." in
629
-
Cmd.info "sidebar-generate" ~docs ~doc
630
-
end
631
-
632
-
module Support_files_command = struct
633
-
let support_files without_theme output_dir =
634
-
Support_files.write ~without_theme output_dir
635
-
636
-
let without_theme =
637
-
let doc = "Don't copy the default theme to output directory." in
638
-
Arg.(value & flag & info ~doc [ "without-theme" ])
639
-
640
-
let cmd = Term.(const support_files $ without_theme $ dst ~create:true ())
641
-
642
-
let info ~docs =
643
-
let doc =
644
-
"Copy the support files (e.g. default theme, JavaScript files) to the \
645
-
output directory."
646
-
in
647
-
Cmd.info ~docs ~doc "support-files"
648
-
end
649
-
650
-
module Css = struct
651
-
let cmd = Support_files_command.cmd
652
-
653
-
let info ~docs =
654
-
let doc =
655
-
"DEPRECATED: Use $(i,odoc support-files) to copy the CSS file for the \
656
-
default theme."
657
-
in
658
-
Cmd.info ~docs ~doc "css"
659
-
end
660
-
661
-
module Odoc_link : sig
662
-
val cmd : unit Term.t
663
-
664
-
val info : docs:string -> Cmd.info
665
-
end = struct
666
-
let get_output_file ~output_file ~input =
667
-
match output_file with
668
-
| Some file -> Fs.File.of_string file
669
-
| None -> Fs.File.(set_ext ".odocl" input)
670
-
671
-
(** Find the package/library name the output is part of *)
672
-
let find_root_of_input l o =
673
-
let l =
674
-
List.map
675
-
~f:(fun (x, p) ->
676
-
(x, p, p |> Fs.Directory.to_fpath |> Antichain.absolute_normalization))
677
-
l
678
-
in
679
-
let o = Antichain.absolute_normalization o in
680
-
match l with
681
-
| [] -> None
682
-
| _ ->
683
-
Odoc_utils.List.find_map
684
-
(fun (root, orig_path, norm_path) ->
685
-
if Fpath.is_prefix norm_path o then Some (root, orig_path) else None)
686
-
l
687
-
688
-
let current_library_of_input lib_roots input =
689
-
find_root_of_input lib_roots input
690
-
691
-
(** Checks if the package specified with [--current-package] is consistent
692
-
with the pages roots and with the output path for pages. *)
693
-
let validate_current_package ?detected_package page_roots current_package =
694
-
match (current_package, detected_package) with
695
-
| Some curpkgnane, Some (detected_package, _)
696
-
when detected_package <> curpkgnane ->
697
-
Error
698
-
(`Msg
699
-
"The package name specified with --current-package is not \
700
-
consistent with the packages passed as a -P")
701
-
| _, (Some _ as r) (* we have equality or only detected package *) -> Ok r
702
-
| None, None -> Ok None
703
-
| Some given, None -> (
704
-
try Ok (Some (given, List.assoc given page_roots))
705
-
with Not_found ->
706
-
Error
707
-
(`Msg
708
-
"The package name specified with --current-package do not match \
709
-
any package passed as a -P"))
710
-
711
-
let find_current_package ~current_package page_roots input =
712
-
let detected_package = find_root_of_input page_roots input in
713
-
validate_current_package ?detected_package page_roots current_package
714
-
715
-
let warnings_tags =
716
-
let doc =
717
-
"Filter warnings that were compiled with a tag that is not in the list \
718
-
of --warnings-tags passed."
719
-
in
720
-
let env = Cmd.Env.info "ODOC_WARNINGS_TAGS" ~doc in
721
-
Arg.(value & opt_all string [] & info ~docs ~doc ~env [ "warnings-tags" ])
722
-
723
-
let link directories page_roots lib_roots input_file output_file
724
-
current_package warnings_options open_modules custom_layout warnings_tags
725
-
=
726
-
let input = Fs.File.of_string input_file in
727
-
let output = get_output_file ~output_file ~input in
728
-
let check () =
729
-
if not custom_layout then
730
-
Antichain.check (page_roots |> List.map ~f:snd) ~opt:"-P" >>= fun () ->
731
-
Antichain.check (lib_roots |> List.map ~f:snd) ~opt:"-L"
732
-
else Ok ()
733
-
in
734
-
check () >>= fun () ->
735
-
let current_lib = current_library_of_input lib_roots input in
736
-
find_current_package ~current_package page_roots input
737
-
>>= fun current_package ->
738
-
let current_dir = Fs.File.dirname input in
739
-
let roots =
740
-
Some
741
-
{
742
-
Resolver.page_roots;
743
-
lib_roots;
744
-
current_lib;
745
-
current_package;
746
-
current_dir;
747
-
}
748
-
in
749
-
750
-
let resolver =
751
-
Resolver.create ~important_digests:false ~directories ~open_modules ~roots
752
-
in
753
-
match
754
-
Odoc_link.from_odoc ~resolver ~warnings_options ~warnings_tags input
755
-
output
756
-
with
757
-
| Error _ as e -> e
758
-
| Ok _ -> Ok ()
759
-
760
-
let dst =
761
-
let doc =
762
-
"Output file path. Non-existing intermediate directories are created. If \
763
-
absent outputs a $(i,.odocl) file in the same directory as the input \
764
-
file with the same basename."
765
-
in
766
-
Arg.(
767
-
value
768
-
& opt (some string) None
769
-
& info ~docs ~docv:"PATH.odocl" ~doc [ "o" ])
770
-
771
-
let page_roots =
772
-
let doc =
773
-
"Specifies a directory DIR containing pages that can be referenced by \
774
-
{!/pkgname/pagename}. A pkgname can be specified in the -P command only \
775
-
once. All the trees specified by this option and -L must be disjoint."
776
-
in
777
-
Arg.(
778
-
value
779
-
& opt_all convert_named_root []
780
-
& info ~docs ~docv:"pkgname:DIR" ~doc [ "P" ])
781
-
782
-
let lib_roots =
783
-
let doc =
784
-
"Specifies a library called libname containing the modules in directory \
785
-
DIR. Modules can be referenced both using the flat module namespace \
786
-
{!Module} and the absolute reference {!/libname/Module}. All the trees \
787
-
specified by this option and -P must be disjoint."
788
-
in
789
-
Arg.(
790
-
value
791
-
& opt_all convert_named_root []
792
-
& info ~docs ~docv:"libname:DIR" ~doc [ "L" ])
793
-
794
-
let current_package =
795
-
let doc =
796
-
"Specify the current package name. The matching page root specified with \
797
-
-P is used to resolve references using the '//' syntax. A \
798
-
corresponding -P option must be passed."
799
-
in
800
-
Arg.(
801
-
value
802
-
& opt (some string) None
803
-
& info ~docs ~docv:"pkgname" ~doc [ "current-package" ])
804
-
805
-
let custom_layout =
806
-
let doc =
807
-
"Signal that a custom layout is being used. This disables the checks \
808
-
that the library and package paths are disjoint."
809
-
in
810
-
Arg.(value & flag (info ~doc [ "custom-layout" ]))
811
-
812
-
let cmd =
813
-
let input =
814
-
let doc = "Input file" in
815
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"FILE.odoc" [])
816
-
in
817
-
Term.(
818
-
const handle_error
819
-
$ (const link $ odoc_file_directories $ page_roots $ lib_roots $ input
820
-
$ dst $ current_package $ warnings_options $ open_modules $ custom_layout
821
-
$ warnings_tags))
822
-
823
-
let info ~docs =
824
-
let man =
825
-
[
826
-
`S "DEPENDENCIES";
827
-
`P
828
-
"Any link step depends on the result of all the compile results that \
829
-
could potentially be needed to resolve forward references. A \
830
-
correct approximation is to start linking only after every compile \
831
-
steps are done, passing everything that's possible to $(i,-I). Link \
832
-
steps don't have dependencies between them.";
833
-
]
834
-
in
835
-
let doc =
836
-
"Second stage of compilation. Link a $(i,.odoc) into a $(i,.odocl)."
837
-
in
838
-
Cmd.info ~docs ~doc ~man "link"
839
-
end
840
-
841
-
module type S = sig
842
-
type args
843
-
844
-
val renderer : args Odoc_document.Renderer.t
845
-
846
-
val extra_args : args Cmdliner.Term.t
847
-
end
848
-
849
-
module Make_renderer (R : S) : sig
850
-
val process : docs:string -> unit Term.t * Cmd.info
851
-
852
-
val targets : docs:string -> unit Term.t * Cmd.info
853
-
854
-
val targets_source : docs:string -> unit Term.t * Cmd.info
855
-
856
-
val generate : docs:string -> unit Term.t * Cmd.info
857
-
858
-
val generate_source : docs:string -> unit Term.t * Cmd.info
859
-
860
-
val generate_asset : docs:string -> unit Term.t * Cmd.info
861
-
end = struct
862
-
let input_odoc =
863
-
let doc = "Input file." in
864
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"FILE.odoc" [])
865
-
866
-
let input_odocl =
867
-
let doc = "Input file." in
868
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"FILE.odocl" [])
869
-
870
-
let input_odocl_list =
871
-
let doc = "Input file(s)." in
872
-
Arg.(non_empty & pos_all file [] & info ~doc ~docv:"FILE.odocl" [])
873
-
874
-
module Process = struct
875
-
let process extra _hidden directories output_dir syntax input_file
876
-
warnings_options =
877
-
let resolver =
878
-
Resolver.create ~important_digests:false ~directories ~open_modules:[]
879
-
~roots:None
880
-
in
881
-
let file = Fs.File.of_string input_file in
882
-
Rendering.render_odoc ~renderer:R.renderer ~resolver ~warnings_options
883
-
~syntax ~output:output_dir extra file
884
-
885
-
let cmd =
886
-
let syntax =
887
-
let doc = "Available options: ml | re" in
888
-
let env = Cmd.Env.info "ODOC_SYNTAX" in
889
-
Arg.(
890
-
value
891
-
& opt convert_syntax Odoc_document.Renderer.OCaml
892
-
@@ info ~docv:"SYNTAX" ~doc ~env [ "syntax" ])
893
-
in
894
-
Term.(
895
-
const handle_error
896
-
$ (const process $ R.extra_args $ hidden $ odoc_file_directories
897
-
$ dst ~create:true () $ syntax $ input_odoc $ warnings_options))
898
-
899
-
let info ~docs =
900
-
let doc =
901
-
Format.sprintf
902
-
"Render %s files from a $(i,.odoc). $(i,link) then $(i,%s-generate) \
903
-
should be used instead."
904
-
R.renderer.name R.renderer.name
905
-
in
906
-
Cmd.info ~docs ~doc R.renderer.name
907
-
end
908
-
909
-
let process ~docs = Process.(cmd, info ~docs)
910
-
911
-
module Generate = struct
912
-
let generate extra _hidden output_dir syntax extra_suffix input_files
913
-
warnings_options sidebar =
914
-
let process_file input_file =
915
-
let file = Fs.File.of_string input_file in
916
-
Rendering.generate_odoc ~renderer:R.renderer ~warnings_options ~syntax
917
-
~output:output_dir ~extra_suffix ~sidebar extra file
918
-
in
919
-
List.fold_left
920
-
~f:(fun acc input_file -> acc >>= fun () -> process_file input_file)
921
-
~init:(Ok ()) input_files
922
-
923
-
let sidebar =
924
-
let doc = "A .odoc-index file, used eg to generate the sidebar." in
925
-
Arg.(
926
-
value
927
-
& opt (some convert_fpath) None
928
-
& info [ "sidebar" ] ~doc ~docv:"FILE.odoc-sidebar")
929
-
930
-
let cmd =
931
-
let syntax =
932
-
let doc = "Available options: ml | re" in
933
-
let env = Cmd.Env.info "ODOC_SYNTAX" in
934
-
Arg.(
935
-
value
936
-
& opt convert_syntax Odoc_document.Renderer.OCaml
937
-
@@ info ~docv:"SYNTAX" ~doc ~env [ "syntax" ])
938
-
in
939
-
Term.(
940
-
const handle_error
941
-
$ (const generate $ R.extra_args $ hidden $ dst ~create:true () $ syntax
942
-
$ extra_suffix $ input_odocl_list $ warnings_options $ sidebar))
943
-
944
-
let info ~docs =
945
-
let doc =
946
-
Format.sprintf "Generate %s files from one or more $(i,.odocl) files."
947
-
R.renderer.name
948
-
in
949
-
Cmd.info ~docs ~doc (R.renderer.name ^ "-generate")
950
-
end
951
-
952
-
let generate ~docs = Generate.(cmd, info ~docs)
953
-
954
-
module Generate_source = struct
955
-
let generate extra output_dir syntax extra_suffix input_file
956
-
warnings_options source_file sidebar =
957
-
Rendering.generate_source_odoc ~renderer:R.renderer ~warnings_options
958
-
~syntax ~output:output_dir ~extra_suffix ~source_file ~sidebar extra
959
-
input_file
960
-
961
-
let input_odocl =
962
-
let doc = "Linked implementation file." in
963
-
Arg.(
964
-
required
965
-
& opt (some convert_fpath) None
966
-
& info [ "impl" ] ~doc ~docv:"impl-FILE.odocl")
967
-
968
-
let source_file =
969
-
let doc = "Source code for the implementation unit." in
970
-
Arg.(
971
-
required
972
-
& pos 0 (some convert_fpath) None
973
-
& info ~doc ~docv:"FILE.ml" [])
974
-
975
-
let cmd =
976
-
let syntax =
977
-
let doc = "Available options: ml | re" in
978
-
let env = Cmd.Env.info "ODOC_SYNTAX" in
979
-
Arg.(
980
-
value
981
-
& opt convert_syntax Odoc_document.Renderer.OCaml
982
-
@@ info ~docv:"SYNTAX" ~doc ~env [ "syntax" ])
983
-
in
984
-
let sidebar = Generate.sidebar in
985
-
Term.(
986
-
const handle_error
987
-
$ (const generate $ R.extra_args $ dst ~create:true () $ syntax
988
-
$ extra_suffix $ input_odocl $ warnings_options $ source_file $ sidebar
989
-
))
990
-
991
-
let info ~docs =
992
-
let doc =
993
-
Format.sprintf "Generate %s files from a $(i,impl-*.odocl)."
994
-
R.renderer.name
995
-
in
996
-
Cmd.info ~docs ~doc (R.renderer.name ^ "-generate-source")
997
-
end
998
-
999
-
let generate_source ~docs = Generate_source.(cmd, info ~docs)
1000
-
1001
-
module Generate_asset = struct
1002
-
let generate extra output_dir extra_suffix input_file warnings_options
1003
-
asset_file =
1004
-
Rendering.generate_asset_odoc ~renderer:R.renderer ~warnings_options
1005
-
~output:output_dir ~extra_suffix ~asset_file extra input_file
1006
-
1007
-
let input_odocl =
1008
-
let doc = "Odoc asset unit." in
1009
-
Arg.(
1010
-
required
1011
-
& opt (some convert_fpath) None
1012
-
& info [ "asset-unit" ] ~doc ~docv:"asset-FILE.odocl")
1013
-
1014
-
let asset_file =
1015
-
let doc = "The asset file" in
1016
-
Arg.(
1017
-
required
1018
-
& pos 0 (some convert_fpath) None
1019
-
& info ~doc ~docv:"FILE.ext" [])
1020
-
1021
-
let cmd =
1022
-
Term.(
1023
-
const handle_error
1024
-
$ (const generate $ R.extra_args $ dst ~create:true () $ extra_suffix
1025
-
$ input_odocl $ warnings_options $ asset_file))
1026
-
1027
-
let info ~docs =
1028
-
let doc =
1029
-
Format.sprintf "Generate %s files from a $(i,impl-*.odocl)."
1030
-
R.renderer.name
1031
-
in
1032
-
Cmd.info ~docs ~doc (R.renderer.name ^ "-generate-asset")
1033
-
end
1034
-
1035
-
let generate_asset ~docs = Generate_asset.(cmd, info ~docs)
1036
-
1037
-
module Targets = struct
1038
-
let list_targets output_dir directories extra odoc_file =
1039
-
let odoc_file = Fs.File.of_string odoc_file in
1040
-
let resolver =
1041
-
Resolver.create ~important_digests:false ~directories ~open_modules:[]
1042
-
~roots:None
1043
-
in
1044
-
let warnings_options =
1045
-
{
1046
-
Odoc_model.Error.warn_error = false;
1047
-
print_warnings = false;
1048
-
warnings_tag = None;
1049
-
}
1050
-
in
1051
-
Rendering.targets_odoc ~resolver ~warnings_options ~syntax:OCaml
1052
-
~renderer:R.renderer ~output:output_dir ~extra odoc_file
1053
-
1054
-
let back_compat =
1055
-
let doc =
1056
-
"For backwards compatibility when processing $(i,.odoc) rather than \
1057
-
$(i,.odocl) files."
1058
-
in
1059
-
Arg.(
1060
-
value
1061
-
& opt_all (convert_directory ()) []
1062
-
& info ~docs ~docv:"DIR" ~doc [ "I" ])
1063
-
1064
-
let cmd =
1065
-
Term.(
1066
-
const handle_error
1067
-
$ (const list_targets $ dst () $ back_compat $ R.extra_args
1068
-
$ input_odocl))
1069
-
1070
-
let info ~docs =
1071
-
let doc =
1072
-
Format.sprintf
1073
-
"Print the files that would be generated by $(i,%s-generate)."
1074
-
R.renderer.name
1075
-
in
1076
-
Cmd.info (R.renderer.name ^ "-targets") ~docs ~doc
1077
-
end
1078
-
1079
-
let targets ~docs = Targets.(cmd, info ~docs)
1080
-
1081
-
module Targets_source = struct
1082
-
let list_targets output_dir source_file extra odoc_file =
1083
-
let warnings_options =
1084
-
{
1085
-
Odoc_model.Error.warn_error = false;
1086
-
print_warnings = false;
1087
-
warnings_tag = None;
1088
-
}
1089
-
in
1090
-
Rendering.targets_source_odoc ~warnings_options ~syntax:OCaml
1091
-
~renderer:R.renderer ~output:output_dir ~extra ~source_file odoc_file
1092
-
1093
-
let source_file = Generate_source.source_file
1094
-
let input_odocl = Generate_source.input_odocl
1095
-
1096
-
let cmd =
1097
-
Term.(
1098
-
const handle_error
1099
-
$ (const list_targets $ dst () $ source_file $ R.extra_args
1100
-
$ input_odocl))
1101
-
1102
-
let info ~docs =
1103
-
let doc =
1104
-
Format.sprintf
1105
-
"Print the files that would be generated by $(i,%s-generate-source)."
1106
-
R.renderer.name
1107
-
in
1108
-
Cmd.info (R.renderer.name ^ "-targets-source") ~docs ~doc
1109
-
end
1110
-
1111
-
let targets_source ~docs = Targets_source.(cmd, info ~docs)
1112
-
end
1113
-
1114
-
module Odoc_latex_url : sig
1115
-
val cmd : unit Term.t
1116
-
1117
-
val info : docs:string -> Cmd.info
1118
-
end = struct
1119
-
let reference =
1120
-
let doc = "The reference to be resolved and whose url to be generated." in
1121
-
Arg.(required & pos 0 (some string) None & info ~doc ~docv:"REF" [])
1122
-
1123
-
let reference_to_url = Url.reference_to_url_latex
1124
-
1125
-
let cmd =
1126
-
Term.(
1127
-
const handle_error
1128
-
$ (const reference_to_url $ odoc_file_directories $ reference))
1129
-
1130
-
let info ~docs =
1131
-
Cmd.info ~docs ~doc:"Resolve a reference and output its corresponding url."
1132
-
"latex-url"
1133
-
end
1134
-
1135
-
module Odoc_html_args = struct
1136
-
include Html_page
1137
-
1138
-
let semantic_uris =
1139
-
let doc = "Generate pretty (semantic) links." in
1140
-
Arg.(value & flag (info ~doc [ "semantic-uris"; "pretty-uris" ]))
1141
-
1142
-
let closed_details =
1143
-
let doc =
1144
-
"If this flag is passed <details> tags (used for includes) will be \
1145
-
closed by default."
1146
-
in
1147
-
Arg.(value & flag (info ~doc [ "closed-details" ]))
1148
-
1149
-
let indent =
1150
-
let doc = "Format the output HTML files with indentation." in
1151
-
Arg.(value & flag (info ~doc [ "indent" ]))
1152
-
1153
-
module Uri = struct
1154
-
(* Very basic validation and normalization for URI paths. *)
1155
-
1156
-
open Odoc_html.Types
1157
-
1158
-
let is_absolute str =
1159
-
List.exists [ "http"; "https"; "file"; "data"; "ftp" ] ~f:(fun scheme ->
1160
-
Astring.String.is_prefix ~affix:(scheme ^ ":") str)
1161
-
|| str.[0] = '/'
1162
-
1163
-
let conv_rel_dir rel =
1164
-
let l = String.cuts ~sep:"/" rel in
1165
-
List.fold_left
1166
-
~f:(fun acc seg ->
1167
-
Some Odoc_document.Url.Path.{ kind = `Page; parent = acc; name = seg })
1168
-
l ~init:None
1169
-
1170
-
let convert_dir : uri Arg.conv =
1171
-
let parser str =
1172
-
if String.length str = 0 then Error "invalid URI"
1173
-
else
1174
-
(* The URI is absolute if it starts with a scheme or with '/'. *)
1175
-
let last_char = str.[String.length str - 1] in
1176
-
let str =
1177
-
if last_char <> '/' then str
1178
-
else String.with_range ~len:(String.length str - 1) str
1179
-
in
1180
-
Ok
1181
-
(if is_absolute str then (Absolute str : uri)
1182
-
else
1183
-
Relative
1184
-
(let u = conv_rel_dir str in
1185
-
match u with
1186
-
| None -> None
1187
-
| Some u -> Some { u with kind = `Page }))
1188
-
in
1189
-
let printer ppf = function
1190
-
| (Absolute uri : uri) -> Format.pp_print_string ppf uri
1191
-
| Relative _uri -> Format.pp_print_string ppf ""
1192
-
in
1193
-
Arg.conv' (parser, printer)
1194
-
1195
-
let convert_file_uri : Odoc_html.Types.file_uri Arg.conv =
1196
-
let parser str =
1197
-
if String.length str = 0 then Error "invalid URI"
1198
-
else
1199
-
let conv_rel_file rel =
1200
-
match String.cut ~rev:true ~sep:"/" rel with
1201
-
| Some (before, after) ->
1202
-
let base = conv_rel_dir before in
1203
-
Odoc_document.Url.Path.
1204
-
{ kind = `File; parent = base; name = after }
1205
-
| None ->
1206
-
Odoc_document.Url.Path.
1207
-
{ kind = `File; parent = None; name = rel }
1208
-
in
1209
-
Ok
1210
-
(if is_absolute str then (Absolute str : file_uri)
1211
-
else Relative (conv_rel_file str))
1212
-
in
1213
-
let printer ppf = function
1214
-
| Odoc_html.Types.Absolute uri -> Format.pp_print_string ppf uri
1215
-
| Odoc_html.Types.Relative _uri -> Format.pp_print_string ppf ""
1216
-
in
1217
-
Arg.conv' (parser, printer)
1218
-
end
1219
-
1220
-
let home_breadcrumb =
1221
-
let doc =
1222
-
"Name for a 'Home' breadcrumb to go up the root of the given sidebar."
1223
-
in
1224
-
Arg.(
1225
-
value
1226
-
& opt (some string) None
1227
-
& info ~docv:"escape" ~doc [ "home-breadcrumb" ])
1228
-
1229
-
let theme_uri =
1230
-
let doc =
1231
-
"Where to look for theme files (e.g. `URI/odoc.css'). Relative URIs are \
1232
-
resolved using `--output-dir' as a target."
1233
-
in
1234
-
let default : Odoc_html.Types.uri = Odoc_html.Types.Relative None in
1235
-
Arg.(
1236
-
value
1237
-
& opt Uri.convert_dir default
1238
-
& info ~docv:"URI" ~doc [ "theme-uri" ])
1239
-
1240
-
let support_uri =
1241
-
let doc =
1242
-
"Where to look for support files (e.g. `URI/highlite.pack.js'). Relative \
1243
-
URIs are resolved using `--output-dir' as a target."
1244
-
in
1245
-
let default : Odoc_html.Types.uri = Odoc_html.Types.Relative None in
1246
-
Arg.(
1247
-
value
1248
-
& opt Uri.convert_dir default
1249
-
& info ~docv:"URI" ~doc [ "support-uri" ])
1250
-
1251
-
let search_uri =
1252
-
let doc =
1253
-
"Where to look for search scripts. Relative URIs are resolved using \
1254
-
`--output-dir' as a target."
1255
-
in
1256
-
Arg.(
1257
-
value
1258
-
& opt_all Uri.convert_file_uri []
1259
-
& info ~docv:"URI" ~doc [ "search-uri" ])
1260
-
1261
-
let flat =
1262
-
let doc =
1263
-
"Output HTML files in 'flat' mode, where the hierarchy of modules / \
1264
-
module types / classes and class types are reflected in the filenames \
1265
-
rather than in the directory structure."
1266
-
in
1267
-
Arg.(value & flag & info ~docs ~doc [ "flat" ])
1268
-
1269
-
let as_json =
1270
-
let doc =
1271
-
"EXPERIMENTAL: Output HTML files in 'embeddable json' mode, where HTML \
1272
-
fragments (preamble, content) together with metadata (uses_katex, \
1273
-
breadcrumbs, table of contents) are emitted in JSON format. The \
1274
-
structure of the output should be considered unstable and no guarantees \
1275
-
are made about backward compatibility."
1276
-
in
1277
-
Arg.(value & flag & info ~doc [ "as-json" ])
1278
-
1279
-
let remap =
1280
-
let convert_remap =
1281
-
let parse inp =
1282
-
match String.cut ~sep:":" inp with
1283
-
| Some (orig, mapped) -> Ok (orig, mapped)
1284
-
| _ -> Error (`Msg "Map must be of the form '<orig>:https://...'")
1285
-
and print fmt (orig, mapped) = Format.fprintf fmt "%s:%s" orig mapped in
1286
-
Arg.conv (parse, print)
1287
-
in
1288
-
let doc = "Remap an identifier to an external URL." in
1289
-
Arg.(value & opt_all convert_remap [] & info [ "R" ] ~doc)
1290
-
1291
-
let remap_file =
1292
-
let doc = "File containing remap rules." in
1293
-
Arg.(value & opt (some file) None & info ~docv:"FILE" ~doc [ "remap-file" ])
1294
-
1295
-
let extra_args =
1296
-
let config semantic_uris closed_details indent theme_uri support_uri
1297
-
search_uris flat as_json remap remap_file home_breadcrumb =
1298
-
let open_details = not closed_details in
1299
-
let remap =
1300
-
match remap_file with
1301
-
| None -> remap
1302
-
| Some f ->
1303
-
Io_utils.fold_lines f
1304
-
(fun line acc ->
1305
-
match String.cut ~sep:":" line with
1306
-
| Some (orig, mapped) -> (orig, mapped) :: acc
1307
-
| None -> acc)
1308
-
[]
1309
-
in
1310
-
let html_config =
1311
-
Odoc_html.Config.v ~theme_uri ~support_uri ~search_uris ~semantic_uris
1312
-
~indent ~flat ~open_details ~as_json ~remap ?home_breadcrumb ()
1313
-
in
1314
-
{ Html_page.html_config }
1315
-
in
1316
-
Term.(
1317
-
const config $ semantic_uris $ closed_details $ indent $ theme_uri
1318
-
$ support_uri $ search_uri $ flat $ as_json $ remap $ remap_file
1319
-
$ home_breadcrumb)
1320
-
end
1321
-
1322
-
module Odoc_html = Make_renderer (Odoc_html_args)
1323
-
1324
-
module Odoc_markdown_cmd = Make_renderer (struct
1325
-
type args = Odoc_markdown.Config.t
1326
-
1327
-
let render config _sidebar page = Odoc_markdown.Generator.render ~config page
1328
-
1329
-
let filepath config url = Odoc_markdown.Generator.filepath ~config url
1330
-
1331
-
let extra_args =
1332
-
Term.const { Odoc_markdown.Config.root_url = None; allow_html = true }
1333
-
let renderer = { Odoc_document.Renderer.name = "markdown"; render; filepath }
1334
-
end)
1335
-
1336
-
module Odoc_html_url : sig
1337
-
val cmd : unit Term.t
1338
-
1339
-
val info : docs:string -> Cmd.info
1340
-
end = struct
1341
-
let root_url =
1342
-
let doc =
1343
-
"A string to prepend to the generated relative url. A separating / is \
1344
-
added if needed."
1345
-
in
1346
-
Arg.(value & opt (some string) None & info [ "r"; "root-url" ] ~doc)
1347
-
1348
-
let reference =
1349
-
let doc = "The reference to be resolved and whose url to be generated." in
1350
-
Arg.(required & pos 0 (some string) None & info ~doc ~docv:"REF" [])
1351
-
1352
-
let reference_to_url = Url.reference_to_url_html
1353
-
1354
-
let cmd =
1355
-
Term.(
1356
-
const handle_error
1357
-
$ (const reference_to_url $ Odoc_html_args.extra_args $ root_url
1358
-
$ odoc_file_directories $ reference))
1359
-
1360
-
let info ~docs =
1361
-
Cmd.info ~docs ~doc:"Resolve a reference and output its corresponding url."
1362
-
"html-url"
1363
-
end
1364
-
1365
-
module Html_fragment : sig
1366
-
val cmd : unit Term.t
1367
-
1368
-
val info : docs:string -> Cmd.info
1369
-
end = struct
1370
-
let html_fragment directories xref_base_uri output_file input_file
1371
-
warnings_options =
1372
-
let resolver =
1373
-
Resolver.create ~important_digests:false ~directories ~open_modules:[]
1374
-
~roots:None
1375
-
in
1376
-
let input_file = Fs.File.of_string input_file in
1377
-
let output_file = Fs.File.of_string output_file in
1378
-
let xref_base_uri =
1379
-
if xref_base_uri = "" then xref_base_uri
1380
-
else
1381
-
let last_char = xref_base_uri.[String.length xref_base_uri - 1] in
1382
-
if last_char <> '/' then xref_base_uri ^ "/" else xref_base_uri
1383
-
in
1384
-
Html_fragment.from_mld ~resolver ~xref_base_uri ~output:output_file
1385
-
~warnings_options input_file
1386
-
1387
-
let cmd =
1388
-
let output =
1389
-
let doc = "Output HTML fragment file." in
1390
-
Arg.(
1391
-
value & opt string "/dev/stdout"
1392
-
& info ~docs ~docv:"file.html" ~doc [ "o"; "output-file" ])
1393
-
in
1394
-
let input =
1395
-
let doc = "Input documentation page file." in
1396
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"file.mld" [])
1397
-
in
1398
-
let xref_base_uri =
1399
-
let doc =
1400
-
"Base URI used to resolve cross-references. Set this to the root of \
1401
-
the global docset during local development. By default `.' is used."
1402
-
in
1403
-
Arg.(value & opt string "" & info ~docv:"URI" ~doc [ "xref-base-uri" ])
1404
-
in
1405
-
Term.(
1406
-
const handle_error
1407
-
$ (const html_fragment $ odoc_file_directories $ xref_base_uri $ output
1408
-
$ input $ warnings_options))
1409
-
1410
-
let info ~docs =
1411
-
Cmd.info ~docs ~doc:"Generates an html fragment file from an mld one."
1412
-
"html-fragment"
1413
-
end
1414
-
1415
-
module Odoc_manpage = Make_renderer (struct
1416
-
type args = unit
1417
-
1418
-
let renderer = Man_page.renderer
1419
-
1420
-
let extra_args = Term.const ()
1421
-
end)
1422
-
1423
-
module Odoc_latex = Make_renderer (struct
1424
-
type args = Latex.args
1425
-
1426
-
let renderer = Latex.renderer
1427
-
1428
-
let with_children =
1429
-
let doc = "Include children at the end of the page." in
1430
-
Arg.(value & opt bool true & info ~docv:"BOOL" ~doc [ "with-children" ])
1431
-
1432
-
let shorten_beyond_depth =
1433
-
let doc = "Shorten items beyond the given depth." in
1434
-
Arg.(
1435
-
value
1436
-
& opt (some' int) None
1437
-
& info ~docv:"INT" ~doc [ "shorten-beyond-depth" ])
1438
-
1439
-
let remove_functor_arg_link =
1440
-
let doc = "Remove link to functor argument." in
1441
-
Arg.(
1442
-
value & opt bool false
1443
-
& info ~docv:"BOOL" ~doc [ "remove-functor-arg-link" ])
1444
-
1445
-
let extra_args =
1446
-
let f with_children shorten_beyond_depth remove_functor_arg_link =
1447
-
{ Latex.with_children; shorten_beyond_depth; remove_functor_arg_link }
1448
-
in
1449
-
Term.(
1450
-
const f $ with_children $ shorten_beyond_depth $ remove_functor_arg_link)
1451
-
end)
1452
-
1453
-
module Depends = struct
1454
-
module Compile = struct
1455
-
let list_dependencies input_files =
1456
-
try
1457
-
let deps =
1458
-
Depends.for_compile_step (List.map ~f:Fs.File.of_string input_files)
1459
-
in
1460
-
List.iter
1461
-
~f:(fun t ->
1462
-
Printf.printf "%s %s\n" (Depends.Compile.name t)
1463
-
(Digest.to_hex @@ Depends.Compile.digest t))
1464
-
deps;
1465
-
flush stdout
1466
-
with Cmi_format.Error e ->
1467
-
let msg =
1468
-
match e with
1469
-
| Not_an_interface file ->
1470
-
Printf.sprintf "File %S is not an interface" file
1471
-
| Wrong_version_interface (file, v) ->
1472
-
Printf.sprintf "File %S is compiled for %s version of OCaml" file
1473
-
v
1474
-
| Corrupted_interface file ->
1475
-
Printf.sprintf "File %S is corrupted" file
1476
-
in
1477
-
Printf.eprintf "ERROR: %s\n%!" msg;
1478
-
exit 1
1479
-
1480
-
let cmd =
1481
-
let input =
1482
-
let doc = "Input files" in
1483
-
Arg.(non_empty & pos_all file [] & info ~doc ~docv:"file.cm{i,t,ti}" [])
1484
-
in
1485
-
Term.(const list_dependencies $ input)
1486
-
1487
-
let info ~docs =
1488
-
Cmd.info "compile-deps" ~docs
1489
-
~doc:
1490
-
"List units (with their digest) which needs to be compiled in order \
1491
-
to compile this one. The unit itself and its digest is also \
1492
-
reported in the output.\n\
1493
-
Dependencies between compile steps are the same as when compiling \
1494
-
the ocaml modules."
1495
-
end
1496
-
1497
-
module Link = struct
1498
-
let rec fmt_page pp page =
1499
-
match page.Odoc_model.Paths.Identifier.iv with
1500
-
| `Page (parent_opt, name) ->
1501
-
Format.fprintf pp "%a%a" fmt_parent_opt parent_opt
1502
-
Odoc_model.Names.PageName.fmt name
1503
-
| `LeafPage (parent_opt, name) ->
1504
-
Format.fprintf pp "%a%a" fmt_parent_opt parent_opt
1505
-
Odoc_model.Names.PageName.fmt name
1506
-
1507
-
and fmt_parent_opt pp parent_opt =
1508
-
match parent_opt with
1509
-
| None -> ()
1510
-
| Some p -> Format.fprintf pp "%a/" fmt_page p
1511
-
1512
-
let list_dependencies input_file =
1513
-
Depends.for_rendering_step (Fs.Directory.of_string input_file)
1514
-
>>= fun depends ->
1515
-
List.iter depends ~f:(fun (root : Odoc_model.Root.t) ->
1516
-
match root.id.iv with
1517
-
| `Root (Some p, _) ->
1518
-
Format.printf "%a %s %s\n" fmt_page p
1519
-
(Odoc_model.Root.Odoc_file.name root.file)
1520
-
(Digest.to_hex root.digest)
1521
-
| _ ->
1522
-
Format.printf "none %s %s\n"
1523
-
(Odoc_model.Root.Odoc_file.name root.file)
1524
-
(Digest.to_hex root.digest));
1525
-
Ok ()
1526
-
1527
-
let cmd =
1528
-
let input =
1529
-
let doc = "Input directory" in
1530
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"PKG_DIR" [])
1531
-
in
1532
-
Term.(const handle_error $ (const list_dependencies $ input))
1533
-
1534
-
let info ~docs =
1535
-
Cmd.info "link-deps" ~docs
1536
-
~doc:
1537
-
"Lists a subset of the packages and modules which need to be in \
1538
-
odoc's load path to link the $(i, odoc) files in the given \
1539
-
directory. Additional packages may be required to resolve all \
1540
-
references."
1541
-
end
1542
-
1543
-
module Odoc_html = struct
1544
-
let includes =
1545
-
let doc = "For backwards compatibility. Ignored." in
1546
-
Arg.(
1547
-
value
1548
-
& opt_all (convert_directory ()) []
1549
-
& info ~docs ~docv:"DIR" ~doc [ "I" ])
1550
-
1551
-
let cmd =
1552
-
let input =
1553
-
let doc = "Input directory" in
1554
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"PKG_DIR" [])
1555
-
in
1556
-
let cmd _ = Link.list_dependencies in
1557
-
Term.(const handle_error $ (const cmd $ includes $ input))
1558
-
1559
-
let info ~docs =
1560
-
Cmd.info "html-deps" ~docs ~doc:"DEPRECATED: alias for link-deps"
1561
-
end
1562
-
end
1563
-
1564
-
module Targets = struct
1565
-
module Compile = struct
1566
-
let list_targets dst input =
1567
-
let input = Fs.File.of_string input in
1568
-
let output = Compile.output_file ~dst ~input in
1569
-
Printf.printf "%s\n" (Fs.File.to_string output);
1570
-
flush stdout
1571
-
1572
-
let cmd = Term.(const list_targets $ Compile.dst $ Compile.input)
1573
-
1574
-
let info ~docs =
1575
-
Cmd.info "compile-targets" ~docs
1576
-
~doc:
1577
-
"Print the name of the file produced by $(i,compile). If $(i,-o) is \
1578
-
passed, the same path is printed but error checking is performed."
1579
-
end
1580
-
1581
-
module Support_files = struct
1582
-
let list_targets without_theme output_directory =
1583
-
Support_files.print_filenames ~without_theme output_directory
1584
-
1585
-
let cmd =
1586
-
Term.(const list_targets $ Support_files_command.without_theme $ dst ())
1587
-
1588
-
let info ~docs =
1589
-
Cmd.info "support-files-targets" ~docs
1590
-
~doc:
1591
-
"Lists the names of the files that $(i,odoc support-files) outputs."
1592
-
end
1593
-
end
1594
-
1595
-
module Occurrences = struct
1596
-
let dst_of_string s =
1597
-
let f = Fs.File.of_string s in
1598
-
if not (Fs.File.has_ext ".odoc-occurrences" f) then
1599
-
Error (`Msg "Output file must have '.odoc-occurrences' extension.")
1600
-
else Ok f
1601
-
1602
-
module Count = struct
1603
-
let count directories dst warnings_options include_hidden =
1604
-
dst_of_string dst >>= fun dst ->
1605
-
Occurrences.count ~dst ~warnings_options directories include_hidden
1606
-
1607
-
let cmd =
1608
-
let dst =
1609
-
let doc = "Output file path." in
1610
-
Arg.(
1611
-
required
1612
-
& opt (some string) None
1613
-
& info ~docs ~docv:"PATH" ~doc [ "o" ])
1614
-
in
1615
-
let include_hidden =
1616
-
let doc = "Include hidden identifiers in the table" in
1617
-
Arg.(value & flag & info ~docs ~doc [ "include-hidden" ])
1618
-
in
1619
-
let input =
1620
-
let doc =
1621
-
"Directories to recursively traverse, agregating occurrences from \
1622
-
$(i,impl-*.odocl) files. Can be present several times."
1623
-
in
1624
-
Arg.(
1625
-
value
1626
-
& pos_all (convert_directory ()) []
1627
-
& info ~docs ~docv:"DIR" ~doc [])
1628
-
in
1629
-
Term.(
1630
-
const handle_error
1631
-
$ (const count $ input $ dst $ warnings_options $ include_hidden))
1632
-
1633
-
let info ~docs =
1634
-
let doc =
1635
-
"Generate a hashtable mapping identifiers to number of occurrences, as \
1636
-
computed from the implementations of .odocl files found in the given \
1637
-
directories."
1638
-
in
1639
-
Cmd.info "count-occurrences" ~docs ~doc
1640
-
end
1641
-
module Aggregate = struct
1642
-
let index dst files file_list strip_path warnings_options =
1643
-
match (files, file_list) with
1644
-
| [], [] ->
1645
-
Error
1646
-
(`Msg
1647
-
"At least one of --file-list or a path to a file must be passed \
1648
-
to odoc aggregate-occurrences")
1649
-
| _ ->
1650
-
dst_of_string dst >>= fun dst ->
1651
-
Occurrences.aggregate ~dst ~warnings_options ~strip_path files
1652
-
file_list
1653
-
1654
-
let cmd =
1655
-
let dst =
1656
-
let doc = "Output file path." in
1657
-
Arg.(
1658
-
required
1659
-
& opt (some string) None
1660
-
& info ~docs ~docv:"PATH" ~doc [ "o" ])
1661
-
in
1662
-
let inputs_in_file =
1663
-
let doc =
1664
-
"Input text file containing a line-separated list of paths to files \
1665
-
created with count-occurrences."
1666
-
in
1667
-
Arg.(
1668
-
value & opt_all convert_fpath []
1669
-
& info ~doc ~docv:"FILE" [ "file-list" ])
1670
-
in
1671
-
let inputs =
1672
-
let doc = "file created with count-occurrences" in
1673
-
Arg.(value & pos_all convert_fpath [] & info ~doc ~docv:"FILE" [])
1674
-
in
1675
-
let strip_path =
1676
-
let doc = "Strip package/version information from paths" in
1677
-
Arg.(value & flag & info ~doc [ "strip-path" ])
1678
-
in
1679
-
Term.(
1680
-
const handle_error
1681
-
$ (const index $ dst $ inputs $ inputs_in_file $ strip_path
1682
-
$ warnings_options))
1683
-
1684
-
let info ~docs =
1685
-
let doc = "Aggregate hashtables created with odoc count-occurrences." in
1686
-
Cmd.info "aggregate-occurrences" ~docs ~doc
1687
-
end
1688
-
end
1689
-
1690
-
module Odoc_error = struct
1691
-
let errors input =
1692
-
let open Odoc_odoc in
1693
-
let input = Fs.File.of_string input in
1694
-
Odoc_file.load input >>= fun unit ->
1695
-
Odoc_model.Error.print_errors unit.warnings;
1696
-
Ok ()
1697
-
1698
-
let input =
1699
-
let doc = "Input $(i,.odoc) or $(i,.odocl) file" in
1700
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"FILE" [])
1701
-
1702
-
let cmd = Term.(const handle_error $ (const errors $ input))
1703
-
1704
-
let info ~docs =
1705
-
Cmd.info "errors" ~docs
1706
-
~doc:"Print errors that occurred while compiling or linking."
1707
-
end
1708
-
1709
-
module Classify = struct
1710
-
let libdirs =
1711
-
let doc = "The directories containing the libraries" in
1712
-
Arg.(value & pos_all string [] & info ~doc ~docv:"DIR" [])
1713
-
1714
-
let cmd = Term.(const handle_error $ (const Classify.classify $ libdirs))
1715
-
1716
-
let info ~docs =
1717
-
Cmd.info "classify" ~docs
1718
-
~doc:
1719
-
"Classify the modules into libraries based on heuristics. Libraries \
1720
-
are specified by the --library option."
1721
-
end
1722
-
1723
-
module Extract_code = struct
1724
-
let extract dst input line_directives names warnings_options =
1725
-
Extract_code.extract ~dst ~input ~line_directives ~names ~warnings_options
1726
-
1727
-
let line_directives =
1728
-
let doc = "Whether to include line directives in the output file" in
1729
-
Arg.(value & flag & info ~doc [ "line-directives" ])
1730
-
1731
-
let names =
1732
-
let doc =
1733
-
"From which name(s) of code blocks to extract content. When no names are \
1734
-
provided, extract all OCaml code blocks."
1735
-
in
1736
-
Arg.(value & opt_all string [] & info ~doc [ "name" ])
1737
-
1738
-
let input =
1739
-
let doc = "Input $(i,.mld) file." in
1740
-
Arg.(required & pos 0 (some file) None & info ~doc ~docv:"FILE" [])
1741
-
1742
-
let dst =
1743
-
let doc = "Output file path." in
1744
-
Arg.(
1745
-
value
1746
-
& opt (some string) None
1747
-
& info ~docs ~docv:"PATH" ~doc [ "o"; "output" ])
1748
-
1749
-
let cmd =
1750
-
Term.(
1751
-
const handle_error
1752
-
$ (const extract $ dst $ input $ line_directives $ names
1753
-
$ warnings_options))
1754
-
1755
-
let info ~docs =
1756
-
Cmd.info "extract-code" ~docs
1757
-
~doc:
1758
-
"Extract code blocks from mld files in order to be able to execute them"
1759
-
end
1760
-
1761
-
let section_pipeline = "COMMANDS: Compilation pipeline"
1762
-
let section_generators = "COMMANDS: Alternative generators"
1763
-
let section_support = "COMMANDS: Scripting"
1764
-
let section_legacy = "COMMANDS: Legacy pipeline"
1765
-
let section_deprecated = "COMMANDS: Deprecated"
1766
-
1767
-
module Extensions = struct
1768
-
let run () =
1769
-
let prefixes = Odoc_extension_api.Registry.list_prefixes () in
1770
-
match prefixes with
1771
-
| [] ->
1772
-
Printf.printf "No extensions installed.\n%!";
1773
-
Printf.printf "Extensions can be installed as opam packages that register with odoc.\n%!"
1774
-
| _ ->
1775
-
Printf.printf "Installed extensions:\n%!";
1776
-
List.iter ~f:(fun prefix -> Printf.printf " @%s\n%!" prefix) prefixes
1777
-
1778
-
let cmd = Term.(const run $ const ())
1779
-
let info ~docs = Cmd.info "extensions" ~docs ~doc:"List installed odoc extensions"
1780
-
end
1781
-
1782
-
(** Sections in the order they should appear. *)
1783
-
let main_page_sections =
1784
-
[
1785
-
section_pipeline;
1786
-
section_generators;
1787
-
section_support;
1788
-
section_legacy;
1789
-
section_deprecated;
1790
-
]
1791
-
1792
-
let () =
1793
-
Printexc.record_backtrace true;
1794
-
let cmd_make (term, info) = Cmd.v info term in
1795
-
let subcommands =
1796
-
List.map ~f:cmd_make
1797
-
@@ [
1798
-
Occurrences.Count.(cmd, info ~docs:section_pipeline);
1799
-
Occurrences.Aggregate.(cmd, info ~docs:section_pipeline);
1800
-
Compile.(cmd, info ~docs:section_pipeline);
1801
-
Compile_asset.(cmd, info ~docs:section_pipeline);
1802
-
Odoc_link.(cmd, info ~docs:section_pipeline);
1803
-
Odoc_html.generate ~docs:section_pipeline;
1804
-
Odoc_html.generate_source ~docs:section_pipeline;
1805
-
Odoc_html.generate_asset ~docs:section_pipeline;
1806
-
Support_files_command.(cmd, info ~docs:section_pipeline);
1807
-
Compile_impl.(cmd, info ~docs:section_pipeline);
1808
-
Indexing.(cmd, info ~docs:section_pipeline);
1809
-
Sidebar.(cmd, info ~docs:section_pipeline);
1810
-
Odoc_markdown_cmd.generate ~docs:section_generators;
1811
-
Odoc_markdown_cmd.generate_source ~docs:section_generators;
1812
-
Odoc_markdown_cmd.targets ~docs:section_support;
1813
-
Odoc_manpage.generate ~docs:section_generators;
1814
-
Odoc_latex.generate ~docs:section_generators;
1815
-
Odoc_html_url.(cmd, info ~docs:section_support);
1816
-
Odoc_latex_url.(cmd, info ~docs:section_support);
1817
-
Targets.Support_files.(cmd, info ~docs:section_support);
1818
-
Odoc_error.(cmd, info ~docs:section_support);
1819
-
Odoc_html.targets ~docs:section_support;
1820
-
Odoc_html.targets_source ~docs:section_support;
1821
-
Odoc_manpage.targets ~docs:section_support;
1822
-
Odoc_latex.targets ~docs:section_support;
1823
-
Depends.Compile.(cmd, info ~docs:section_support);
1824
-
Targets.Compile.(cmd, info ~docs:section_support);
1825
-
Html_fragment.(cmd, info ~docs:section_legacy);
1826
-
Odoc_html.process ~docs:section_legacy;
1827
-
Odoc_manpage.process ~docs:section_legacy;
1828
-
Odoc_latex.process ~docs:section_legacy;
1829
-
Depends.Link.(cmd, info ~docs:section_legacy);
1830
-
Css.(cmd, info ~docs:section_deprecated);
1831
-
Depends.Odoc_html.(cmd, info ~docs:section_deprecated);
1832
-
Classify.(cmd, info ~docs:section_pipeline);
1833
-
Extract_code.(cmd, info ~docs:section_pipeline);
1834
-
Extensions.(cmd, info ~docs:section_support);
1835
-
]
1836
-
in
1837
-
let main =
1838
-
let print_default () =
1839
-
let available_subcommands =
1840
-
List.map subcommands ~f:(fun cmd -> Cmd.name cmd)
1841
-
in
1842
-
Printf.printf
1843
-
"Available subcommands: %s\nSee --help for more information.\n%!"
1844
-
(String.concat ~sep:", " available_subcommands)
1845
-
in
1846
-
let man =
1847
-
(* Show sections in a defined order. *)
1848
-
List.map ~f:(fun s -> `S s) main_page_sections
1849
-
in
1850
-
let default = Term.(const print_default $ const ()) in
1851
-
let info = Cmd.info ~man ~version:"%%VERSION%%" "odoc" in
1852
-
Cmd.group ~default info subcommands
1853
-
in
1854
-
match Cmd.eval_value ~err:Format.err_formatter main with
1855
-
| Error _ ->
1856
-
Format.pp_print_flush Format.err_formatter ();
1857
-
exit 2
1858
-
| _ -> ()
-384
test/scrollycode-demos/warm_parser.mld
-384
test/scrollycode-demos/warm_parser.mld
···
1
-
{0 Building a JSON Parser}
2
-
3
-
@scrolly.warm Building a JSON Parser in OCaml
4
-
{ol
5
-
{li
6
-
{b Defining the Value Type}
7
-
8
-
Every parser starts with a type. JSON has six kinds of values:
9
-
null, booleans, numbers, strings, arrays, and objects.
10
-
We encode this directly as an OCaml variant.
11
-
12
-
{[
13
-
type json =
14
-
| Null
15
-
| Bool of bool
16
-
| Number of float
17
-
| String of string
18
-
| Array of json list
19
-
| Object of (string * json) list
20
-
]}
21
-
}
22
-
{li
23
-
{b A Simple Scanner}
24
-
25
-
Before parsing structure, we need to skip whitespace and
26
-
peek at the next meaningful character. Our scanner works
27
-
on a string with a mutable position index.
28
-
29
-
{[
30
-
type json =
31
-
| Null
32
-
| Bool of bool
33
-
| Number of float
34
-
| String of string
35
-
| Array of json list
36
-
| Object of (string * json) list
37
-
38
-
type scanner = {
39
-
input : string;
40
-
mutable pos : int;
41
-
}
42
-
43
-
let peek s =
44
-
while s.pos < String.length s.input
45
-
&& s.input.[s.pos] = ' ' do
46
-
s.pos <- s.pos + 1
47
-
done;
48
-
if s.pos < String.length s.input
49
-
then Some s.input.[s.pos]
50
-
else None
51
-
52
-
let advance s = s.pos <- s.pos + 1
53
-
]}
54
-
}
55
-
{li
56
-
{b Parsing Strings}
57
-
58
-
JSON strings are delimited by double quotes. We scan character
59
-
by character, collecting into a buffer. This handles the simple
60
-
case without escape sequences.
61
-
62
-
{[
63
-
type json =
64
-
| Null
65
-
| Bool of bool
66
-
| Number of float
67
-
| String of string
68
-
| Array of json list
69
-
| Object of (string * json) list
70
-
71
-
type scanner = {
72
-
input : string;
73
-
mutable pos : int;
74
-
}
75
-
76
-
let peek s =
77
-
while s.pos < String.length s.input
78
-
&& s.input.[s.pos] = ' ' do
79
-
s.pos <- s.pos + 1
80
-
done;
81
-
if s.pos < String.length s.input
82
-
then Some s.input.[s.pos]
83
-
else None
84
-
85
-
let advance s = s.pos <- s.pos + 1
86
-
87
-
let parse_string s =
88
-
advance s;
89
-
let buf = Buffer.create 64 in
90
-
while s.pos < String.length s.input
91
-
&& s.input.[s.pos] <> '"' do
92
-
Buffer.add_char buf s.input.[s.pos];
93
-
advance s
94
-
done;
95
-
advance s;
96
-
Buffer.contents buf
97
-
]}
98
-
}
99
-
{li
100
-
{b Parsing Numbers}
101
-
102
-
Numbers in JSON can be integers or floats. We collect consecutive
103
-
digit and dot characters, then use float_of_string to parse them.
104
-
A production parser would handle exponents too.
105
-
106
-
{[
107
-
type json =
108
-
| Null
109
-
| Bool of bool
110
-
| Number of float
111
-
| String of string
112
-
| Array of json list
113
-
| Object of (string * json) list
114
-
115
-
type scanner = {
116
-
input : string;
117
-
mutable pos : int;
118
-
}
119
-
120
-
let peek s =
121
-
while s.pos < String.length s.input
122
-
&& s.input.[s.pos] = ' ' do
123
-
s.pos <- s.pos + 1
124
-
done;
125
-
if s.pos < String.length s.input
126
-
then Some s.input.[s.pos]
127
-
else None
128
-
129
-
let advance s = s.pos <- s.pos + 1
130
-
131
-
let parse_string s =
132
-
advance s;
133
-
let buf = Buffer.create 64 in
134
-
while s.pos < String.length s.input
135
-
&& s.input.[s.pos] <> '"' do
136
-
Buffer.add_char buf s.input.[s.pos];
137
-
advance s
138
-
done;
139
-
advance s;
140
-
Buffer.contents buf
141
-
142
-
let is_digit c = c >= '0' && c <= '9'
143
-
144
-
let parse_number s =
145
-
let start = s.pos in
146
-
while s.pos < String.length s.input
147
-
&& (is_digit s.input.[s.pos]
148
-
|| s.input.[s.pos] = '.'
149
-
|| s.input.[s.pos] = '-') do
150
-
advance s
151
-
done;
152
-
float_of_string
153
-
(String.sub s.input start (s.pos - start))
154
-
]}
155
-
}
156
-
{li
157
-
{b The Recursive Core}
158
-
159
-
Now the magic: parse_value dispatches on the next character
160
-
to decide what kind of JSON value to parse. For atoms like
161
-
null, true, false we match literal strings. For compound
162
-
structures, we recurse.
163
-
164
-
{[
165
-
type json =
166
-
| Null
167
-
| Bool of bool
168
-
| Number of float
169
-
| String of string
170
-
| Array of json list
171
-
| Object of (string * json) list
172
-
173
-
type scanner = {
174
-
input : string;
175
-
mutable pos : int;
176
-
}
177
-
178
-
let peek s =
179
-
while s.pos < String.length s.input
180
-
&& s.input.[s.pos] = ' ' do
181
-
s.pos <- s.pos + 1
182
-
done;
183
-
if s.pos < String.length s.input
184
-
then Some s.input.[s.pos]
185
-
else None
186
-
187
-
let advance s = s.pos <- s.pos + 1
188
-
189
-
let parse_string s =
190
-
advance s;
191
-
let buf = Buffer.create 64 in
192
-
while s.pos < String.length s.input
193
-
&& s.input.[s.pos] <> '"' do
194
-
Buffer.add_char buf s.input.[s.pos];
195
-
advance s
196
-
done;
197
-
advance s;
198
-
Buffer.contents buf
199
-
200
-
let is_digit c = c >= '0' && c <= '9'
201
-
202
-
let parse_number s =
203
-
let start = s.pos in
204
-
while s.pos < String.length s.input
205
-
&& (is_digit s.input.[s.pos]
206
-
|| s.input.[s.pos] = '.'
207
-
|| s.input.[s.pos] = '-') do
208
-
advance s
209
-
done;
210
-
float_of_string
211
-
(String.sub s.input start (s.pos - start))
212
-
213
-
let expect s c =
214
-
match peek s with
215
-
| Some c' when c' = c -> advance s
216
-
| _ -> failwith "unexpected character"
217
-
218
-
let rec parse_value s =
219
-
match peek s with
220
-
| Some '"' -> String (parse_string s)
221
-
| Some c when is_digit c || c = '-' ->
222
-
Number (parse_number s)
223
-
| Some 't' ->
224
-
s.pos <- s.pos + 4; Bool true
225
-
| Some 'f' ->
226
-
s.pos <- s.pos + 5; Bool false
227
-
| Some 'n' ->
228
-
s.pos <- s.pos + 4; Null
229
-
| Some '[' -> parse_array s
230
-
| Some '{' -> parse_object s
231
-
| _ -> failwith "unexpected token"
232
-
233
-
and parse_array s =
234
-
advance s;
235
-
let items = ref [] in
236
-
(match peek s with
237
-
| Some ']' -> advance s
238
-
| _ ->
239
-
items := [parse_value s];
240
-
while peek s = Some ',' do
241
-
advance s;
242
-
items := parse_value s :: !items
243
-
done;
244
-
expect s ']');
245
-
Array (List.rev !items)
246
-
247
-
and parse_object s =
248
-
advance s;
249
-
let pairs = ref [] in
250
-
(match peek s with
251
-
| Some '}' -> advance s
252
-
| _ ->
253
-
let key = parse_string s in
254
-
expect s ':';
255
-
let value = parse_value s in
256
-
pairs := [(key, value)];
257
-
while peek s = Some ',' do
258
-
advance s;
259
-
let k = parse_string s in
260
-
expect s ':';
261
-
let v = parse_value s in
262
-
pairs := (k, v) :: !pairs
263
-
done;
264
-
expect s '}');
265
-
Object (List.rev !pairs)
266
-
]}
267
-
}
268
-
{li
269
-
{b The Public API}
270
-
271
-
Finally we wrap the scanner in a clean top-level function.
272
-
Pass a string in, get a JSON value out. The entire parser
273
-
is about 80 lines of OCaml — no dependencies, no magic.
274
-
275
-
{[
276
-
type json =
277
-
| Null
278
-
| Bool of bool
279
-
| Number of float
280
-
| String of string
281
-
| Array of json list
282
-
| Object of (string * json) list
283
-
284
-
type scanner = {
285
-
input : string;
286
-
mutable pos : int;
287
-
}
288
-
289
-
let peek s =
290
-
while s.pos < String.length s.input
291
-
&& s.input.[s.pos] = ' ' do
292
-
s.pos <- s.pos + 1
293
-
done;
294
-
if s.pos < String.length s.input
295
-
then Some s.input.[s.pos]
296
-
else None
297
-
298
-
let advance s = s.pos <- s.pos + 1
299
-
300
-
let parse_string s =
301
-
advance s;
302
-
let buf = Buffer.create 64 in
303
-
while s.pos < String.length s.input
304
-
&& s.input.[s.pos] <> '"' do
305
-
Buffer.add_char buf s.input.[s.pos];
306
-
advance s
307
-
done;
308
-
advance s;
309
-
Buffer.contents buf
310
-
311
-
let is_digit c = c >= '0' && c <= '9'
312
-
313
-
let parse_number s =
314
-
let start = s.pos in
315
-
while s.pos < String.length s.input
316
-
&& (is_digit s.input.[s.pos]
317
-
|| s.input.[s.pos] = '.'
318
-
|| s.input.[s.pos] = '-') do
319
-
advance s
320
-
done;
321
-
float_of_string
322
-
(String.sub s.input start (s.pos - start))
323
-
324
-
let expect s c =
325
-
match peek s with
326
-
| Some c' when c' = c -> advance s
327
-
| _ -> failwith "unexpected character"
328
-
329
-
let rec parse_value s =
330
-
match peek s with
331
-
| Some '"' -> String (parse_string s)
332
-
| Some c when is_digit c || c = '-' ->
333
-
Number (parse_number s)
334
-
| Some 't' ->
335
-
s.pos <- s.pos + 4; Bool true
336
-
| Some 'f' ->
337
-
s.pos <- s.pos + 5; Bool false
338
-
| Some 'n' ->
339
-
s.pos <- s.pos + 4; Null
340
-
| Some '[' -> parse_array s
341
-
| Some '{' -> parse_object s
342
-
| _ -> failwith "unexpected token"
343
-
344
-
and parse_array s =
345
-
advance s;
346
-
let items = ref [] in
347
-
(match peek s with
348
-
| Some ']' -> advance s
349
-
| _ ->
350
-
items := [parse_value s];
351
-
while peek s = Some ',' do
352
-
advance s;
353
-
items := parse_value s :: !items
354
-
done;
355
-
expect s ']');
356
-
Array (List.rev !items)
357
-
358
-
and parse_object s =
359
-
advance s;
360
-
let pairs = ref [] in
361
-
(match peek s with
362
-
| Some '}' -> advance s
363
-
| _ ->
364
-
let key = parse_string s in
365
-
expect s ':';
366
-
let value = parse_value s in
367
-
pairs := [(key, value)];
368
-
while peek s = Some ',' do
369
-
advance s;
370
-
let k = parse_string s in
371
-
expect s ':';
372
-
let v = parse_value s in
373
-
pairs := (k, v) :: !pairs
374
-
done;
375
-
expect s '}');
376
-
Object (List.rev !pairs)
377
-
378
-
let parse input =
379
-
let s = { input; pos = 0 } in
380
-
let v = parse_value s in
381
-
v
382
-
]}
383
-
}
384
-
}