this repo has no description
1(*
2 * Copyright (c) 2014 Leo White <leo@lpw25.net>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *)
16
17open Odoc_utils
18open ResultMonad
19open Odoc_model
20
21type unit_content = Lang.Compilation_unit.t
22
23type content =
24 | Page_content of Lang.Page.t
25 | Impl_content of Lang.Implementation.t
26 | Unit_content of unit_content
27 | Asset_content of Lang.Asset.t
28
29type t = { content : content; warnings : Odoc_model.Error.t list }
30
31(** Written at the top of the files. Checked when loading. *)
32let magic = "odoc-3.0.0"
33
34(** Exceptions while saving are allowed to leak. *)
35let save_ file f =
36 Fs.Directory.mkdir_p (Fs.File.dirname file);
37 Io_utils.with_open_out_bin (Fs.File.to_string file) (fun oc ->
38 output_string oc magic;
39 f oc)
40
41let save_unit file (root : Root.t) (t : t) =
42 save_ file (fun oc ->
43 Marshal.to_channel oc root [];
44 Marshal.to_channel oc t [])
45
46let save_page file ~warnings page =
47 let dir = Fs.File.dirname file in
48 let base = Fs.File.(to_string @@ basename file) in
49 let file =
50 if Astring.String.is_prefix ~affix:"page-" base then file
51 else Fs.File.create ~directory:dir ~name:("page-" ^ base)
52 in
53 save_unit file page.Lang.Page.root { content = Page_content page; warnings }
54
55let save_impl file ~warnings impl =
56 let dir = Fs.File.dirname file in
57 let base = Fs.File.(to_string @@ basename file) in
58 let file =
59 if Astring.String.is_prefix ~affix:"impl-" base then file
60 else Fs.File.create ~directory:dir ~name:("impl-" ^ base)
61 in
62 save_unit file impl.Lang.Implementation.root
63 { content = Impl_content impl; warnings }
64
65let save_asset file ~warnings asset =
66 let dir = Fs.File.dirname file in
67 let base = Fs.File.(to_string @@ basename file) in
68 let file =
69 if Astring.String.is_prefix ~affix:"asset-" base then file
70 else Fs.File.create ~directory:dir ~name:("asset-" ^ base)
71 in
72 let t = { content = Asset_content asset; warnings } in
73 save_unit file asset.root t
74
75let save_unit file ~warnings m =
76 save_unit file m.Lang.Compilation_unit.root
77 { content = Unit_content m; warnings }
78
79let load_ file f =
80 let file = Fs.File.to_string file in
81 (if Sys.file_exists file then Ok file
82 else Error (`Msg (Printf.sprintf "File does not exist")))
83 >>= fun file ->
84 Io_utils.with_open_in_bin file @@ fun ic ->
85 try
86 let actual_magic = really_input_string ic (String.length magic) in
87 if actual_magic = magic then f ic
88 else
89 let msg =
90 Printf.sprintf "%s: invalid magic number %S, expected %S\n%!" file
91 actual_magic magic
92 in
93 Error (`Msg msg)
94 with exn ->
95 let msg =
96 Printf.sprintf "Error while unmarshalling %S: %s\n%!" file
97 (match exn with Failure s -> s | _ -> Printexc.to_string exn)
98 in
99 Error (`Msg msg)
100
101let load file =
102 load_ file (fun ic ->
103 let _root = Marshal.from_channel ic in
104 Ok (Marshal.from_channel ic))
105
106(** The root is saved separately in the files to support this function. *)
107let load_root file =
108 load_ file (fun ic ->
109 let root = Marshal.from_channel ic in
110 Ok root)
111
112let save_index dst idx = save_ dst (fun oc -> Marshal.to_channel oc idx [])
113
114let load_index file = load_ file (fun ic -> Ok (Marshal.from_channel ic))
115
116let save_sidebar dst idx = save_ dst (fun oc -> Marshal.to_channel oc idx [])
117
118let load_sidebar file = load_ file (fun ic -> Ok (Marshal.from_channel ic))