jon.recoil.org
this repo has no description
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
6open Odoc_utils
7open ResultMonad
8module List = ListLabels
9open Odoc_odoc
10open Cmdliner
11
12(* Load all installed extensions at startup *)
13
14
15let 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
27let 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. *)
41let 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
49let 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
60let 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
69module 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)
99end
100
101let docs = "ARGUMENTS"
102
103let 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
112let 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
118let 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
129let 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
174let 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
181let 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
188module 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
198end = 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
363end
364
365module 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
406end
407
408module 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
479end
480
481module 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
579end
580
581module 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
630end
631
632module 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"
648end
649
650module 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"
659end
660
661module Odoc_link : sig
662 val cmd : unit Term.t
663
664 val info : docs:string -> Cmd.info
665end = 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"
839end
840
841module type S = sig
842 type args
843
844 val renderer : args Odoc_document.Renderer.t
845
846 val extra_args : args Cmdliner.Term.t
847end
848
849module 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
861end = 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)
1112end
1113
1114module Odoc_latex_url : sig
1115 val cmd : unit Term.t
1116
1117 val info : docs:string -> Cmd.info
1118end = 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"
1133end
1134
1135module 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)
1320end
1321
1322module Odoc_html = Make_renderer (Odoc_html_args)
1323
1324module 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 }
1334end)
1335
1336module Odoc_html_url : sig
1337 val cmd : unit Term.t
1338
1339 val info : docs:string -> Cmd.info
1340end = 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"
1363end
1364
1365module Html_fragment : sig
1366 val cmd : unit Term.t
1367
1368 val info : docs:string -> Cmd.info
1369end = 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"
1413end
1414
1415module Odoc_manpage = Make_renderer (struct
1416 type args = unit
1417
1418 let renderer = Man_page.renderer
1419
1420 let extra_args = Term.const ()
1421end)
1422
1423module 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)
1451end)
1452
1453module 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
1562end
1563
1564module 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
1593end
1594
1595module 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
1688end
1689
1690module 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."
1707end
1708
1709module 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."
1721end
1722
1723module 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"
1759end
1760
1761let section_pipeline = "COMMANDS: Compilation pipeline"
1762let section_generators = "COMMANDS: Alternative generators"
1763let section_support = "COMMANDS: Scripting"
1764let section_legacy = "COMMANDS: Legacy pipeline"
1765let section_deprecated = "COMMANDS: Deprecated"
1766
1767module 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"
1780end
1781
1782(** Sections in the order they should appear. *)
1783let main_page_sections =
1784 [
1785 section_pipeline;
1786 section_generators;
1787 section_support;
1788 section_legacy;
1789 section_deprecated;
1790 ]
1791
1792let () =
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 | _ -> ()