this repo has no description
Merge commit '1b37b8d5302512238877e1aad43459c3efe7b8a4'
+4676
+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
+
}