-
Notifications
You must be signed in to change notification settings - Fork 0
/
reader.ml
172 lines (147 loc) · 5.28 KB
/
reader.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
166
167
168
169
170
171
172
open Core
module type Reader_intf = sig
module Config : sig
type options
type t
val options_of_sexp : Sexp.t -> options
val empty_options : options
val merge_options : options -> options -> options
val of_options : default:t -> options -> t
end
val read_from_channel : Config.t -> int -> In_channel.t -> Eval.Context.t
end
exception Read_error of string
module Table_config = struct
type options = {
strict : bool sexp_option;
separator: char list sexp_option;
default : float sexp_option;
transpose: bool sexp_option;
} [@@deriving sexp]
type t = {
strict : bool;
separator: char list;
default : float;
transpose: bool;
}
let empty_options : options = {
strict = None;
separator = None;
default = None;
transpose = None;
}
let merge_options (opt1 : options) (opt2 : options) : options = {
strict = Option.first_some opt2.strict opt1.strict;
separator = Option.first_some opt2.separator opt1.separator;
default = Option.first_some opt2.default opt1.default;
transpose = Option.first_some opt2.transpose opt1.transpose;
}
let of_options ~default (opt : options) = {
strict = Option.value ~default:default.strict opt.strict;
separator = Option.value ~default:default.separator opt.separator;
default = Option.value ~default:default.default opt.default;
transpose = Option.value ~default:default.transpose opt.transpose;
}
end
let split_words sep str = String.split_on_chars ~on:sep str
|> List.filter ~f:(fun word -> word <> "")
let read_num strict default str =
let num = try Float.of_string str with
| Invalid_argument _ ->
if strict then raise (Read_error ("cannot read as a number: " ^ str))
else default
in
Value.Num num
let read_line strict sep default line =
split_words sep line |> List.map ~f:(read_num strict default)
let create_table strict sep default lines =
let lines = List.map lines ~f:(read_line strict sep default) in
let widths = List.map lines ~f:List.length in
let width = List.fold widths ~init:0 ~f:Int.max in
if strict && List.exists widths ~f:(fun w -> w <> width) then
raise (Read_error "table is incomplete");
List.map lines ~f:(fun line ->
let row = Array.create ~len:width (Value.Num default) in
List.iteri line ~f:(fun i v -> row.(i) <- v);
row
)
|> Array.of_list
let create_ctx_alist id table =
let table_v = Value.Vec table in
let ctx_alist =
if id = 0 then Array.to_list table
|> List.mapi ~f:(fun i v -> ("$" ^ Int.to_string i, v))
else []
in
let ctx_alist' =
if id = 0 then ("$$", table_v) :: ("$$0", table_v) :: ctx_alist
else ("$$" ^ Int.to_string id, table_v) :: ctx_alist
in
ctx_alist'
module Table = struct
module Config = Table_config
let remove_comments lines =
List.filter lines ~f:(fun line -> String.prefix line 1 <> "#")
let read_from_channel config id ch =
let {
Config.strict;
Config.separator = sep;
Config.default;
Config.transpose = trans;
} = config in
let transpose = if trans then Fn.id else Array.transpose_exn in
let table = In_channel.input_lines ch
|> List.filter ~f:(fun line -> line <> "")
|> remove_comments
|> create_table strict sep default
|> transpose
|> Array.map ~f:(fun row -> Value.Vec row)
in
let ctx_alist = create_ctx_alist id table in
Eval.Context.of_alist ctx_alist
end
module Table_ex = struct
module Config = Table_config
let valid_name_re = Re2.create_exn "^[A-Za-z\\$][A-Za-z0-9\\$_']*$"
let valid_name name = Re2.matches valid_name_re name
let read_const consts strict default str =
match split_words [' '; '\t'] str with
| name :: value :: rest ->
if strict && List.length rest <> 0 then
raise (Read_error ("invalid constant definition: " ^ str));
let valid = valid_name name in
if strict && not valid then
raise (Read_error ("invalid name: " ^ name));
if valid then
Hashtbl.set consts ~key:name ~data:(read_num strict default value)
| _ ->
if strict then
raise (Read_error ("invalid constant definition: " ^ str))
let read_and_remove_comments consts strict default lines =
List.filter lines ~f:(fun line ->
if String.prefix line 1 <> "#" then true
else begin
if String.prefix line 2 = "##" && String.prefix line 3 <> "###" then
read_const consts strict default (String.drop_prefix line 2);
false
end
)
let read_from_channel config id ch =
let {
Config.strict;
Config.separator = sep;
Config.default;
Config.transpose = trans;
} = config in
let transpose = if trans then Fn.id else Array.transpose_exn in
let consts = Hashtbl.create (module String) in
let table = In_channel.input_lines ch
|> List.filter ~f:(fun line -> line <> "")
|> read_and_remove_comments consts strict default
|> create_table strict sep default
|> transpose
|> Array.map ~f:(fun row -> Value.Vec row)
in
let ctx_alist = create_ctx_alist id table @ Hashtbl.to_alist consts in
Eval.Context.of_alist ctx_alist
end