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
open Ast
let copy_pmml_file src dst =
match (try Ok (open_in_bin src) with Sys_error msg -> Error msg) with
| Error msg ->
Error (Printf.sprintf "could not open source PMML path `%s`: %s" src msg)
| Ok ic ->
Fun.protect ~finally:(fun () -> close_in_noerr ic) (fun () ->
match (try Ok (open_out_bin dst) with Sys_error msg -> Error msg) with
| Error msg ->
Error (Printf.sprintf "could not open destination PMML path `%s`: %s" dst msg)
| Ok oc ->
Fun.protect ~finally:(fun () -> close_out_noerr oc) (fun () ->
let buffer = Bytes.create 65536 in
let rec loop () =
try
match input ic buffer 0 (Bytes.length buffer) with
| 0 -> Ok ()
| read ->
output oc buffer 0 read;
loop ()
with
| Sys_error msg ->
Error
(Printf.sprintf
"failed while copying `%s` to `%s`: %s"
src dst msg)
in
loop ()))
let pmml_source_path = function
| VDict pairs ->
(match List.assoc_opt "_pmml_path" pairs with
| Some (VString path) -> Some path
| _ -> None)
| _ -> None
(*
--# Read a PMML model file
--#
--# Loads a PMML file from disk and returns its parsed model representation.
--#
--# @name t_read_pmml
--# @family stats
--# @export
*)
let t_read_pmml_builtin =
make_builtin ~name:"t_read_pmml" 1 (fun args _env ->
match args with
| [VString path] ->
(match Pmml_utils.read_pmml path with
| Ok v -> Pmml_utils.attach_source_path path v
| Error msg -> Error.make_error FileError msg)
| [VError _ as e] -> e
| _ -> Error.type_error "t_read_pmml expects a single String argument.")
let t_write_pmml_builtin =
make_builtin ~name:"t_write_pmml" 2 (fun args _env ->
match args with
| [VError _ as e; _] | [_; VError _ as e] -> e
| [VDict _ as model; VString path] ->
(match pmml_source_path model with
| Some src_path ->
if not (Sys.file_exists src_path) then
Error.make_error FileError
(Printf.sprintf
"Function `t_write_pmml`: source PMML artifact `%s` no longer exists, so the pass-through copy cannot be written."
src_path)
else
(match copy_pmml_file src_path path with
| Ok () -> VString path
| Error msg ->
Error.make_error FileError
(Printf.sprintf "Function `t_write_pmml` failed to write `%s`: %s" path msg))
| None ->
Error.make_error RuntimeError
"Function `t_write_pmml` currently supports only PMML models loaded via `t_read_pmml()` or `read_node()`. Exporting native T models to PMML is not implemented yet.")
| [_; VString _] ->
Error.type_error "Function `t_write_pmml` expects a PMML model Dict as first argument."
| [VDict _; _] ->
Error.type_error "Function `t_write_pmml` expects a String path as second argument."
| [_; _] ->
Error.type_error "Function `t_write_pmml` expects (Dict, String)."
| _ ->
Error.arity_error_named "t_write_pmml" 2 (List.length args)
)
let register env =
Serialization_registry.update_native "pmml" ~writer:t_write_pmml_builtin ~reader:t_read_pmml_builtin ();
let env = Env.add "t_read_pmml" t_read_pmml_builtin env in
let env = Env.add "t_write_pmml" t_write_pmml_builtin env in
env