Source file dump.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
module AcgEnv = AcgData.Environment.Environment
module Data_parser = Grammars.Parsers

module Log = UtilsLib.Xlog.Make (
  struct
    let name = "Dump"
end)


module LoadingErrors_l =
  struct
    type t =
      | EmptyFile
      | IncompatibleVersion of string

    let kind = "Loading"

    let pp fmt err =
      match err with
      | EmptyFile -> Format.fprintf fmt "Empty@ file"
      | IncompatibleVersion v -> Format.fprintf fmt "This@ file@ was@ compiled@ with@ an@ incompatible@ version@ of@ ACGtk@ (%s)" v
  end

module LoadingErrors = UtilsLib.Error.ErrorManager(LoadingErrors_l)


let file_header = "acg object file version "
let stamp v = Printf.sprintf "%s%s" file_header v
let compatible_version header = header = stamp UtilsLib.Version.version

type file_type =
  | Object
  | Data

let is_acg_object filename in_ch =
  let loc = { Lexing.pos_fname = filename ; pos_lnum = 0 ; pos_cnum = 0 ; pos_bol = 0} in
  let loc = (loc, loc) in
  let first_line = In_channel.input_line in_ch in
  match first_line with
  | None -> LoadingErrors.emit LoadingErrors_l.EmptyFile ~loc
  | Some first_line ->
    if String.starts_with ~prefix:file_header first_line then
      if compatible_version first_line then
        true
      else
        let () = In_channel.close in_ch in
        LoadingErrors.emit (LoadingErrors_l.IncompatibleVersion first_line) ~loc
    else
      false

let load_env_buf ~with_magic lexbuf env =
  match Data_parser.parse_data ~no_magic:(not with_magic) ~overwrite:true lexbuf env with
  | None -> failwith "Loading error"
  | Some env -> (Data, env)

let load_env_str ~with_magic str env =
  let lexbuf = Sedlexing.Utf8.from_string str in
    load_env_buf ~with_magic lexbuf env

let load_env ~with_magic filename dirs env loc =
  let file = UtilsLib.Utils.find_file filename dirs loc in
  let in_ch = In_channel.open_bin file in
  if is_acg_object filename in_ch then
    let file_env:AcgEnv.dumped_t = Marshal.from_channel in_ch in
    let () = In_channel.close in_ch in
      (Object, AcgEnv.append env file_env)
  else
    let () = In_channel.seek in_ch 0L in
      let lexbuf = Sedlexing.Utf8.from_channel in_ch in
      let () = Sedlexing.set_filename lexbuf filename in
      load_env_buf ~with_magic lexbuf env

let save_env ~force filename env =
  let () =
    Log.debug (fun m ->
      m "The environment currently has %d signature(s) and %d lexicon(s)."
        (AcgEnv.sig_number env) (AcgEnv.lex_number env))
  in
  let new_env = AcgEnv.prepare_dump ~force ~filename env in
  let out_ch = Out_channel.open_bin filename in
  let () = Printf.fprintf out_ch "%s\n" (stamp UtilsLib.Version.version) in
  let t = UtilsLib.Timer.top () in
  let () =
    Marshal.to_channel out_ch new_env []
  in
  let () = UtilsLib.Timer.debug (fun m -> m "Marshalling@ and@ file@ writing: %a" UtilsLib.Timer.elapsed t) in
  close_out out_ch