Source file reject_or_error.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
open! Core
open! Async

type t =
  { reject : Smtp_reply.t option [@sexp.option]
  ; error : Error.t
  ; here : Source_code_position.t option [@sexp.option]
  }
[@@deriving sexp_of]

let error t =
  match t.here with
  | None -> t.error
  | Some here ->
    Error.of_thunk (fun () ->
      sprintf !"%{Error#hum}\nat %{Source_code_position}" t.error here)
;;

let reject t = t.reject
let of_error ?reject ~here error = { reject; error; here = Some here }
let of_exn ?reject ~here exn = of_error ?reject ~here (Error.of_exn exn)
let of_string ?reject ~here msg = of_error ?reject ~here (Error.of_string msg)
let createf ?reject ~here fmt = ksprintf (of_string ?reject ~here) fmt

let of_reject ~here reject =
  of_error ~reject ~here (Error.create "REJECT" reject [%sexp_of: Smtp_reply.t])
;;

let of_list ts =
  { reject = List.find_map ts ~f:reject
  ; error = Error.of_list (List.map ts ~f:error)
  ; here = None
  }
;;

let tag_error ~tag t = { t with error = Error.tag t.error ~tag }

let maybe_tag_error ?tag t =
  match tag with
  | None -> t
  | Some tag -> tag_error ~tag t
;;

let tag_here ~here t =
  match t.here with
  | None -> { t with here = Some here }
  | Some here' ->
    if Source_code_position.equal here here'
    then t
    else { t with here = Some here; error = error t }
;;

let maybe_tag_here ?here t =
  match here with
  | None -> t
  | Some here -> tag_here ~here t
;;

let tag ~tag ?here t = tag_error ~tag t |> maybe_tag_here ?here
let tag' ?tag ?here t = maybe_tag_error ?tag t |> maybe_tag_here ?here