Source file row.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
(* Copyright (C) 2025  Petter A. Urkedal <paurkedal@gmail.com>
 *
 * This library is free software; you can redistribute it and/or modify it
 * under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or (at your
 * option) any later version, with the LGPL-3.0 Linking Exception.
 *
 * This library is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
 * License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * and the LGPL-3.0 Linking Exception along with this library.  If not, see
 * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
 *)

(* equal *)

let rec equal_poly : type a. a Row_type.t -> a -> a -> bool =
  (function
   | Field ft ->
      Field_type.equal_value ft
   | Option t ->
      let equal_t = equal_poly t in
      fun x y ->
        (match x, y with
         | None, None -> true
         | Some x, Some y -> equal_t x y
         | None, Some _ | Some _, None -> false)
   | Product (_, pt) -> equal_product pt
   | Annot (_, t) -> equal_poly t)

and equal_product : type i a. (i, a) Row_type.product -> a -> a -> bool =
  (function
   | Proj_end -> fun _ _ -> true
   | Proj (t, p, pt) ->
      let equal_t = equal_poly t in
      let equal_pt = equal_product pt in
      fun x y -> equal_t (p x) (p y) && equal_pt x y)

let equal (t : _ Row_type.t) = equal_poly t

(* pp *)

type pp_state = {
  mutable field_num: int;
}

let pp_field_sep state ppf () =
  if state.field_num > 0 then
    begin
      Format.pp_print_char ppf ',';
      Format.pp_print_space ppf ()
    end;
  state.field_num <- state.field_num + 1

let pp_rep_lit n lit state =
  fun ppf () ->
    for _ = 1 to n do
      pp_field_sep state ppf ();
      Format.pp_print_string ppf lit
    done

let rec pp_poly
  : type a. a Row_type.t -> pp_state -> Format.formatter -> a -> unit =
  (function
   | Field ft ->
      fun state ppf x ->
        pp_field_sep state ppf ();
        Field_type.pp_value ppf (ft, x)
   | Option t ->
      let pp_t = pp_poly t in
      let length_t = Row_type.length t in
      fun state ->
        let case_none = pp_rep_lit length_t "NONE" state in
        let case_some = pp_t state in
        fun ppf ->
          (function None -> case_none ppf () | Some x -> case_some ppf x)
   | Product (_, pt) -> pp_product pt
   | Annot (`Redacted, t) ->
      let length_t = Row_type.length t in
      fun state ppf _ -> pp_rep_lit length_t "#redacted#" state ppf ())

and pp_product
  : type i a. (i, a) Row_type.product -> pp_state ->
    Format.formatter -> a -> unit =
  (function
   | Proj_end -> fun _state _ppf _x -> ()
   | Proj (t, p, pt) ->
      let pp_t = pp_poly t in
      let pp_pt = pp_product pt in
      fun state ->
        let pp_t_state = pp_t state in
        let pp_pt_state = pp_pt state in
        fun ppf x ->
          pp_t_state ppf (p x);
          pp_pt_state ppf x)

let pp (t : _ Row_type.t) = pp_poly t {field_num = 1}