type table = Mappings | Locations | Functions

let pp_table ppf = function
  | Mappings -> Fmt.string ppf "mapping"
  | Locations -> Fmt.string ppf "location"
  | Functions -> Fmt.string ppf "function"

type kind = Loc.Error.kind = ..

type Loc.Error.kind +=
  | Gzip of string
  | Too_large of { limit : int }
  | Missing_string_table
  | First_string_not_empty of string
  | String_index_out_of_range of { field : string; index : int64; len : int }
  | Missing_sample_type
  | Value_count_mismatch of { values : int; types : int }
  | Reserved_id of table
  | Duplicate_id of { table : table; id : int64 }
  | Dangling_id of { table : table; id : int64; from : string }

type t = Loc.Error.t

let () =
  Loc.Error.register_kind_printer (function
    | Gzip msg -> Some (fun ppf -> Fmt.pf ppf "gzip: %s" msg)
    | Too_large { limit } ->
        Some (fun ppf -> Fmt.pf ppf "profile exceeds the %d byte limit" limit)
    | Missing_string_table ->
        Some
          (fun ppf ->
            Fmt.string ppf "missing string table: string_table[0] must be \"\"")
    | First_string_not_empty s ->
        Some
          (fun ppf ->
            Fmt.pf ppf "string_table[0] is %S, must be the empty string" s)
    | String_index_out_of_range { field; index; len } ->
        Some
          (fun ppf ->
            Fmt.pf ppf "%s: string index %Ld out of range [0;%d]" field index
              (len - 1))
    | Missing_sample_type ->
        Some
          (fun ppf -> Fmt.string ppf "samples present but sample_type is empty")
    | Value_count_mismatch { values; types } ->
        Some
          (fun ppf ->
            Fmt.pf ppf "sample has %d values but sample_type declares %d" values
              types)
    | Reserved_id table ->
        Some (fun ppf -> Fmt.pf ppf "%a has reserved id 0" pp_table table)
    | Duplicate_id { table; id } ->
        Some (fun ppf -> Fmt.pf ppf "duplicate %a id %Ld" pp_table table id)
    | Dangling_id { table; id; from } ->
        Some
          (fun ppf ->
            Fmt.pf ppf "%s references %a id %Ld, which is not declared" from
              pp_table table id)
    | _ -> None)

let string_of_kind = Loc.Error.string_of_kind
let pp = Loc.Error.pp
let to_string = Loc.Error.to_string
let raise_kind k = Loc.Error.raise ~ctx:Loc.Context.empty ~meta:Loc.Meta.none k
let gzip msg = raise_kind (Gzip msg)
let too_large limit = raise_kind (Too_large { limit })
let missing_string_table () = raise_kind Missing_string_table
let first_string_not_empty s = raise_kind (First_string_not_empty s)

let string_index_out_of_range ~field ~index ~len =
  raise_kind (String_index_out_of_range { field; index; len })

let missing_sample_type () = raise_kind Missing_sample_type

let value_count_mismatch ~values ~types =
  raise_kind (Value_count_mismatch { values; types })

let reserved_id table = raise_kind (Reserved_id table)
let duplicate_id ~table ~id = raise_kind (Duplicate_id { table; id })
let dangling_id ~table ~id ~from = raise_kind (Dangling_id { table; id; from })
let catch f = match f () with v -> Ok v | exception Loc.Error e -> Error e