Source file `rendering.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
open Odoc_utils
open ResultMonad
open Odoc_document
open Odoc_model

let prepare ~extra_suffix ~output_dir filename =
  let filename =
    match extra_suffix with
    | Some s -> Fpath.add_ext s filename
    | None -> filename
  in
  let filename = Fpath.normalize @@ Fs.File.append output_dir filename in
  let directory = Fs.File.dirname filename in
  Fs.Directory.mkdir_p directory;
  filename

let document_of_odocl ~syntax input =
  Odoc_file.load input >>= fun unit ->
  match unit.content with
  | Odoc_file.Page_content odoctree ->
      Ok (Renderer.document_of_page ~syntax odoctree)
  | Unit_content odoctree ->
      Ok (Renderer.document_of_compilation_unit ~syntax odoctree)
  | Impl_content _ ->
      Error
        (`Msg
           "Wrong kind of unit: Expected a page or module unit, got an \
            implementation. Use the dedicated command for implementation.")
  | Asset_content _ ->
      Error
        (`Msg
           "Wrong kind of unit: Expected a page or module unit, got an asset \
            unit. Use the dedicated command for assets.")

let document_of_input ~resolver ~warnings_options ~syntax input =
  let output = Fs.File.(set_ext ".odocl" input) in
  Odoc_link.from_odoc ~resolver ~warnings_options ~warnings_tags:[] input output
  >>= function
  | `Page page -> Ok (Renderer.document_of_page ~syntax page)
  | `Module m -> Ok (Renderer.document_of_compilation_unit ~syntax m)
  | `Impl _ ->
      Error
        (`Msg
           "Wrong kind of unit: Expected a page or module unit, got an \
            implementation. Use the dedicated command for implementation.")
  | `Asset _ ->
      Error
        (`Msg
           "Wrong kind of unit: Expected a page or module unit, got an asset \
            unit. Use the dedicated command for assets.")

let render_document renderer ~sidebar ~output:root_dir ~extra_suffix ~extra doc
    =
  let pages = renderer.Renderer.render extra sidebar doc in
  Renderer.traverse pages ~f:(fun filename content assets ->
      let filename = prepare ~extra_suffix ~output_dir:root_dir filename in
      (* Write assets to the same directory as the HTML file *)
      let asset_dir = Fpath.parent filename in
      List.iter (fun (asset : Odoc_extension_registry.asset) ->
        let asset_path = Fpath.(asset_dir / asset.asset_filename) in
        Io_utils.with_open_out_bin (Fs.File.to_string asset_path) @@ fun oc ->
        output_bytes oc asset.asset_content
      ) assets;
      (* Write the HTML content *)
      Io_utils.with_formatter_out (Fs.File.to_string filename) @@ fun fmt ->
      Format.fprintf fmt "%t@?" content)

let render_odoc ~resolver ~warnings_options ~syntax ~renderer ~output extra file
    =
  let extra_suffix = None in
  document_of_input ~resolver ~warnings_options ~syntax file >>= fun doc ->
  render_document renderer ~sidebar:None ~output ~extra_suffix ~extra doc;
  Ok ()

let generate_odoc ~syntax ~warnings_options:_ ~renderer ~output ~extra_suffix
    ~sidebar extra file =
  (match sidebar with
  | None -> Ok None
  | Some x -> Odoc_file.load_sidebar x >>= fun sidebar -> Ok (Some sidebar))
  >>= fun sidebar ->
  document_of_odocl ~syntax file >>= fun doc ->
  render_document renderer ~output ~sidebar ~extra_suffix ~extra doc;
  Ok ()

let documents_of_implementation ~warnings_options:_ ~syntax impl source_file =
  match impl.Lang.Implementation.id with
  | Some _ -> (
      match Fs.File.read source_file with
      | Error (`Msg msg) ->
          Error (`Msg (Format.sprintf "Couldn't load source file: %s" msg))
      | Ok source_code ->
          let syntax_info =
            Syntax_highlighter.syntax_highlighting_locs source_code
          in
          let rendered =
            Odoc_document.Renderer.documents_of_implementation ~syntax impl
              syntax_info source_code
          in
          Ok rendered)
  | None ->
      Error (`Msg "The implementation unit was not compiled with --source-id.")

let generate_source_odoc ~syntax ~warnings_options ~renderer ~output
    ~source_file ~extra_suffix ~sidebar extra file =
  Odoc_file.load file >>= fun unit ->
  (match sidebar with
  | None -> Ok None
  | Some x -> Odoc_file.load_sidebar x >>= fun sidebar -> Ok (Some sidebar))
  >>= fun sidebar ->
  match unit.content with
  | Odoc_file.Impl_content impl ->
      documents_of_implementation ~warnings_options ~syntax impl source_file
      >>= fun docs ->
      List.iter
        (render_document renderer ~output ~sidebar ~extra_suffix ~extra)
        docs;
      Ok ()
  | Page_content _ | Unit_content _ | Asset_content _ ->
      Error (`Msg "Expected an implementation unit")

let generate_asset_odoc ~warnings_options:_ ~renderer ~output ~asset_file
    ~extra_suffix extra file =
  Odoc_file.load file >>= fun unit ->
  match unit.content with
  | Odoc_file.Asset_content unit ->
      let url = Odoc_document.Url.Path.from_identifier unit.name in
      let filename = renderer.Renderer.filepath extra url in
      let dst = prepare ~extra_suffix ~output_dir:output filename in
      Fs.File.copy ~src:asset_file ~dst
  | Page_content _ | Unit_content _ | Impl_content _ ->
      Error (`Msg "Expected an asset unit")

let targets_odoc ~resolver ~warnings_options ~syntax ~renderer ~output:root_dir
    ~extra odoctree =
  let doc =
    if Fpath.get_ext odoctree = ".odoc" then
      document_of_input ~resolver ~warnings_options ~syntax odoctree
    else document_of_odocl ~syntax odoctree
  in
  doc >>= fun doc ->
  let pages = renderer.Renderer.render extra None doc in
  Renderer.traverse pages ~f:(fun filename _content _assets ->
      let filename = Fpath.normalize @@ Fs.File.append root_dir filename in
      Format.printf "%a\n" Fpath.pp filename);
  Ok ()

let targets_source_odoc ~syntax ~warnings_options ~renderer ~output:root_dir
    ~extra ~source_file odoctree =
  Odoc_file.load odoctree >>= fun unit ->
  match unit.content with
  | Odoc_file.Impl_content impl ->
      documents_of_implementation ~warnings_options ~syntax impl source_file
      >>= fun docs ->
      List.iter
        (fun doc ->
          let pages = renderer.Renderer.render extra None doc in
          Renderer.traverse pages ~f:(fun filename _content _assets ->
              let filename =
                Fpath.normalize @@ Fs.File.append root_dir filename
              in
              Format.printf "%a\n" Fpath.pp filename))
        docs;
      Ok ()
  | Page_content _ | Unit_content _ | Asset_content _ ->
      Error (`Msg "Expected an implementation unit")
Source file rendering.ml

Source file `rendering.ml`
