Source file wave_format.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
open! Core0

(* We cannot serialize the [Custom] constructor. Instead we map it to a simple conversion
   to a bit string. *)
module Custom = struct
  module M = struct
    type t = unit [@@deriving bin_io]
  end

  module T = struct
    type t = Bits.t -> string [@@deriving sexp_of]

    let of_binable () =
      let simple_conversion t = Bits.to_string t in
      simple_conversion
    ;;

    let to_binable (_ : t) = ()

    let caller_identity =
      Bin_prot.Shape.Uuid.of_string "7f52c42b-a0bf-4241-ba12-31e009fd768d"
    ;;
  end

  include T
  include Binable.Of_binable_with_uuid (M) (T)
end

type t =
  | Binary
  | Bit
  | Bit_or of t
  | Hex
  | Unsigned_int
  | Int
  | Index of string list
  | Custom of Custom.t
  | Map of (Bits.t, string) List.Assoc.t
[@@deriving bin_io, sexp_of]

let%template[@mode local] rec equal (a @ local) (b @ local) =
  match a, b with
  | Binary, Binary | Bit, Bit | Hex, Hex | Int, Int | Unsigned_int, Unsigned_int -> true
  | Bit_or a, Bit_or b -> (equal [@mode local]) a b
  | Index a, Index b -> ([%compare.equal: string list] [@mode local]) a b
  | Custom f, Custom g -> phys_equal f g
  | Map m, Map n -> ([%equal: (Bits.t * string) list] [@mode local]) m n
  | (Bit | Bit_or _ | Binary | Hex | Unsigned_int | Int | Index _ | Custom _ | Map _), _
    -> false
;;

let%template equal = [%eta2 equal [@mode local]]

let rec to_string t =
  match t with
  | Binary | Bit ->
    (fun (bits : Bits.t) -> Constant.to_binary_string (bits :> Constant.t))
    |> Staged.stage
  | Bit_or t ->
    let to_string (bits : Bits.t) =
      if Bits.width bits = 1
      then Constant.to_binary_string (bits :> Constant.t)
      else Staged.unstage (to_string t) bits
    in
    Staged.stage to_string
  | Hex ->
    let to_string (bits : Bits.t) =
      Constant.to_hex_string ~capitalize:true ~signedness:Unsigned (bits :> Constant.t)
    in
    Staged.stage to_string
  | Unsigned_int ->
    let to_string (bits : Bits.t) =
      match Bits.to_unsigned_int bits |> Int.to_string with
      | exception _ ->
        Constant.to_bigint ~signedness:Unsigned (bits :> Constant.t) |> Bigint.to_string
      | bits -> bits
    in
    Staged.stage to_string
  | Int ->
    let to_string (bits : Bits.t) =
      match Bits.to_signed_int bits |> Int.to_string with
      | exception _ ->
        Constant.to_bigint ~signedness:Signed (bits :> Constant.t) |> Bigint.to_string
      | bits -> bits
    in
    Staged.stage to_string
  | Index strings ->
    let strings = Array.of_list strings in
    let to_string (bits : Bits.t) =
      match strings.(Bits.to_int_trunc bits) with
      | exception _ -> "-"
      | s -> s
    in
    Staged.stage to_string
  | Map map ->
    let map = Map.of_alist_exn (module Bits) map in
    let to_string (bits : Bits.t) =
      match Map.find map bits with
      | None -> "-"
      | Some s -> s
    in
    Staged.stage to_string
  | Custom f -> Staged.stage f
;;

let default = Bit_or Hex

let of_string_exn s =
  match String.lowercase s with
  | "b" | "bin" | "binary" -> Binary
  | "h" | "hex" -> Hex
  | "u" | "uint" | "unsigned" | "unsigned-int" -> Unsigned_int
  | "s" | "int" | "sint" | "signed" | "signed-int" -> Int
  | s -> raise_s [%message "Invalid wave_format" (s : string)]
;;