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
open Ast
(** Construct the canonical public node-record structure exposed by
[which_nodes] and [errored_nodes]. These fields define the stable public
API contract for node records, and predicate expressions plus
documentation rely on exactly [name], [value], and [diagnostics].
The field names must match {!Ast.Utils.node_record_scope_fields} so the
evaluator's scoped-NSE desugaring rewrites bare names correctly. *)
let node_record name value diagnostics =
VDict [
("name", VString name);
("value", value);
("diagnostics", Ast.Utils.node_diagnostics_to_value diagnostics);
]
let make_predicate_arg node = [(None, Ast.mk_expr (Value node))]
let eval_node_predicate ~fn_name ~eval_call env predicate node =
match eval_call env predicate (make_predicate_arg node) with
| VBool b -> Ok b
| VError _ as e -> Error e
| other ->
Error
(Error.type_error
(Printf.sprintf
"Function `%s` predicate must return Bool, got %s."
fn_name
(Utils.type_name other)))
(*
--# Filter Readable Pipeline Node Records
--#
--# Returns the node records from `read_pipeline(p).nodes` that satisfy a
--# predicate. Unlike `filter_node`, this is a read-only query helper: it does
--# not return a new Pipeline. Predicates can be written either as explicit
--# functions (for example `\(node) !is_na(node.diagnostics.error)`) or as
--# concise expressions that refer directly to node-record fields such as
--# `name`, `value`, and `diagnostics`.
--#
--# @name which_nodes
--# @param p :: Pipeline The pipeline to inspect.
--# @param predicate :: Function A predicate over read-pipeline node records.
--# @return :: List A list of node records from `read_pipeline(p).nodes`.
--# @example
--# which_nodes(p, !is_na(diagnostics.error))
--# which_nodes(p, name == "model")
--# which_nodes(p, \(node) node.name == "model")
--# @family pipeline
--# @seealso read_pipeline, filter_node, select_node
--# @export
*)
let which_nodes_impl ~fn_name ~eval_call args env =
match args with
| [VPipeline p; predicate] ->
let merged_nodes =
Builder.merge_pipeline_nodes_with_latest_log p
in
let merged_diagnostics =
Builder.merge_pipeline_node_diagnostics_with_latest_log p
in
let get_node_record name value =
let diagnostics =
match List.assoc_opt name merged_diagnostics with
| Some diagnostics -> diagnostics
| None -> Ast.Utils.empty_node_diagnostics
in
node_record name value diagnostics
in
let rec aux acc = function
| [] -> VList (List.rev acc)
| (name, value) :: rest ->
let node = get_node_record name value in
(match eval_node_predicate ~fn_name ~eval_call env predicate node with
| Ok true -> aux ((None, node) :: acc) rest
| Ok false -> aux acc rest
| Error e -> e)
in
aux [] merged_nodes
| [_; _] -> Error.type_error (Printf.sprintf "Function `%s` expects a Pipeline as first argument." fn_name)
| _ -> Error.arity_error_named fn_name 2 (List.length args)
(*
--# Get Errored Pipeline Nodes
--#
--# Returns the read-pipeline node records whose `diagnostics.error` field is
--# not `NA`. This is a convenience wrapper around `which_nodes`.
--#
--# @name errored_nodes
--# @param p :: Pipeline The pipeline to inspect.
--# @return :: List A list of node records with captured errors.
--# @example
--# errored_nodes(p)
--# @family pipeline
--# @seealso which_nodes, read_pipeline
--# @export
*)
let errored_nodes_impl ~eval_call args env =
let predicate =
VLambda {
params = ["node"];
autoquote_params = [false];
param_types = [None];
return_type = None;
generic_params = [];
variadic = false;
body =
Ast.mk_expr
(UnOp {
op = Not;
operand =
Ast.mk_expr
(Call {
fn = Ast.mk_expr (Var "is_na");
args = [
(None,
Ast.mk_expr
(DotAccess {
target =
Ast.mk_expr
(DotAccess {
target = Ast.mk_expr (Var "node");
field = "diagnostics";
});
field = "error";
}));
];
});
});
env = Some env;
}
in
match args with
| [pipeline] -> which_nodes_impl ~fn_name:"errored_nodes" ~eval_call [pipeline; predicate] env
| _ -> Error.arity_error_named "errored_nodes" 1 (List.length args)
let register ~eval_call env =
env
|> Env.add "which_nodes"
(make_builtin ~name:"which_nodes" 2 (fun args env ->
which_nodes_impl ~fn_name:"which_nodes" ~eval_call args env))
|> Env.add "errored_nodes"
(make_builtin ~name:"errored_nodes" 1 (fun args env ->
match args with
| [VPipeline _] -> errored_nodes_impl ~eval_call args env
| [_] -> Error.type_error "Function `errored_nodes` expects a Pipeline."
| _ -> Error.arity_error_named "errored_nodes" 1 (List.length args)))