Source file `reason_utop.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
# 1 "reason_utop.cppo.ml"
(** * Some of this was coppied from \@whitequark's m17n project. *)
(*
 * Portions Copyright (c) 2015-present, Facebook, Inc.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

open Reason

module ToploopBackup = struct
  let print_out_value = !Toploop.print_out_value
  let print_out_type = !Toploop.print_out_type
  let print_out_class_type = !Toploop.print_out_class_type
  let print_out_module_type = !Toploop.print_out_module_type
  let print_out_type_extension = !Toploop.print_out_type_extension
  let print_out_sig_item = !Toploop.print_out_sig_item
  let print_out_signature = !Toploop.print_out_signature
  let print_out_phrase = !Toploop.print_out_phrase

  let[@ocaml.warning "-3"] current_show =
    Hashtbl.find Toploop.directive_table "show"
end

# 36 "reason_utop.cppo.ml"
let rec lident_operator_map mapper li =
  let open Longident in
  match li with
  | Lident s -> Lident (mapper s)
  | Ldot (x, s) -> Ldot (x, mapper s)
  | Lapply (x, y) ->
    Lapply (lident_operator_map mapper x, lident_operator_map mapper y)

# 45 "reason_utop.cppo.ml"
type top_kind =
  | RTop
  | UTop

let current_top = ref RTop

let init_reason () =
  if List.exists (( = ) "camlp4o") !Topfind.predicates
     || List.exists (( = ) "camlp4r") !Topfind.predicates
  then print_endline "Reason is incompatible with camlp4!"
  else
    let use_file x =
      List.map
        Reason_toolchain.To_current.copy_toplevel_phrase
        (Reason_toolchain.RE.use_file x)
    in
    current_top := RTop;
    UTop.set_phrase_terminator ";";
    UTop.prompt :=
      fst
        (React.S.create
           LTerm_text.(eval [ B_fg LTerm_style.green; S "Reason # " ]));
    UTop.parse_toplevel_phrase :=
      UTop.parse_default
        (Reason_util.correctly_catch_parse_errors (fun x ->
           Reason_toolchain.To_current.copy_toplevel_phrase
             (Reason_toolchain.RE.toplevel_phrase x)));
    UTop.parse_use_file :=
      UTop.parse_default (Reason_util.correctly_catch_parse_errors use_file);
    UTop.history_file_name :=
      Some (Filename.concat LTerm_resources.home ".rtop-history");

    Toploop.parse_use_file := Reason_util.correctly_catch_parse_errors use_file;

    (* Printing in Reason syntax *)
    let open Reason_toolchain.From_current in
    let wrap f g fmt x =
      g fmt (f x)
    in
    
# 85 "reason_utop.cppo.ml"
    let wrap_doc f g fmt x =
      let doc_f =
        Format_doc.deprecated_printer (fun fmt -> Format.fprintf fmt "%a" g (f x))
      in
      doc_f fmt
    
# 93 "reason_utop.cppo.ml"
    in
    Toploop.print_out_value := wrap copy_out_value Reason_oprint.print_out_value;
    Toploop.print_out_type := wrap_doc copy_out_type Reason_oprint.print_out_type;
    Toploop.print_out_class_type :=
      wrap_doc copy_out_class_type Reason_oprint.print_out_class_type;
    Toploop.print_out_module_type :=
      wrap_doc copy_out_module_type Reason_oprint.print_out_module_type;
    Toploop.print_out_type_extension :=
      wrap_doc copy_out_type_extension Reason_oprint.print_out_type_extension;
    Toploop.print_out_sig_item :=
      wrap_doc copy_out_sig_item Reason_oprint.print_out_sig_item;
    Toploop.print_out_signature :=
      wrap_doc (List.map copy_out_sig_item) Reason_oprint.print_out_signature;
    Toploop.print_out_phrase :=
      wrap copy_out_phrase Reason_oprint.print_out_phrase;
    let current_show_fn =
      match ToploopBackup.current_show with
      | Toploop.Directive_ident fn -> fn
      | _ -> assert false
    in
    Hashtbl.replace
      (Toploop.directive_table [@ocaml.warning "-3"])
      "show"
      (Toploop.Directive_ident
         (fun li ->
           let li' =
             lident_operator_map Reason_syntax_util.reason_to_ml_swap li
           in
           current_show_fn li'))

let init_ocaml () =
  current_top := UTop;
  UTop.set_phrase_terminator ";;";
  UTop.prompt :=
    fst
      (React.S.create
         LTerm_text.(eval [ B_fg LTerm_style.green; S "OCaml # " ]));
  UTop.parse_toplevel_phrase := UTop.parse_toplevel_phrase_default;
  UTop.parse_use_file := UTop.parse_use_file_default;
  UTop.history_file_name :=
    Some (Filename.concat LTerm_resources.home ".utop-history");

  Toploop.print_out_value := ToploopBackup.print_out_value;
  Toploop.print_out_type := ToploopBackup.print_out_type;
  Toploop.print_out_class_type := ToploopBackup.print_out_class_type;
  Toploop.print_out_module_type := ToploopBackup.print_out_module_type;
  Toploop.print_out_type_extension := ToploopBackup.print_out_type_extension;
  Toploop.print_out_sig_item := ToploopBackup.print_out_sig_item;
  Toploop.print_out_signature := ToploopBackup.print_out_signature;
  Toploop.print_out_phrase := ToploopBackup.print_out_phrase;
  Hashtbl.replace
    (Toploop.directive_table [@ocaml.warning "-3"])
    "show"
    ToploopBackup.current_show

let toggle_syntax () =
  match !current_top with RTop -> init_ocaml () | UTop -> init_reason ()

let () =
  Hashtbl.add
    (Toploop.directive_table [@ocaml.warning "-3"])
    "toggle_syntax"
    (Toploop.Directive_none toggle_syntax);
  init_reason ()