Source file runtime.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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
open Base

[%%template
[@@@mode.default m = (local, global)]

type 'a test_pred =
  ?here:Lexing.position list
  -> ?message:string
  -> ('a @ m -> bool) @ local
  -> 'a @ m
  -> unit

type 'a test_eq =
  ?here:Lexing.position list
  -> ?message:string
  -> ?equal:('a @ m -> 'a @ m -> bool) @ local
  -> 'a @ m
  -> 'a @ m
  -> unit

type ('a : value_or_null) test_result =
  ?here:Lexing.position list
  -> ?message:string
  -> ?equal:('a @ m -> 'a @ m -> bool) @ local
  -> expect:'a @ m
  -> 'a @ m
  -> unit]

let%template[@alloc heap] globalize_sexp sexp = sexp
let%template[@alloc stack] globalize_sexp sexp = Sexp.globalize sexp

exception E of string * Sexp.t [@@deriving sexp]

let exn_sexp_style ~message ~pos ~here ~tag body =
  let message =
    match message with
    | None -> tag
    | Some s -> s ^ ": " ^ tag
  in
  let sexp =
    Sexp.List
      (body
       @ [ Sexp.List [ Sexp.Atom "Loc"; Sexp.Atom pos ] ]
       @
       match here with
       | [] -> []
       | _ ->
         [ Sexp.List [ Sexp.Atom "Stack"; [%sexp_of: Source_code_position.t list] here ] ]
      )
  in
  (* Here and in other places we return exceptions, rather than directly raising, and
     instead raise at the latest moment possible, so backtrace don't include noise from
     these functions that construct exceptions. *)
  E (message, sexp)
;;

let[@cold] exn_test_eq ~message ~pos ~here ~t1 ~t2 =
  exn_sexp_style ~message ~pos ~here ~tag:"comparison failed" [ t1; Sexp.Atom "vs"; t2 ]
;;

let[@cold] exn_test_result ~message ~pos ~here ~expect ~got =
  exn_sexp_style
    ~message
    ~pos
    ~here
    ~tag:"got unexpected result"
    [ Sexp.List [ Sexp.Atom "expected"; expect ]; Sexp.List [ Sexp.Atom "got"; got ] ]
;;

let r_diff = Dynamic.make (None : (from_:string -> to_:string -> unit) option)
let set_diff_function f = Dynamic.set_root r_diff f

[%%template
[@@@alloc.default a @ m = (stack_local, heap_global)]

let[@cold] exn_test_pred ~message ~pos ~here ~sexpifier t =
  exn_sexp_style
    ~message
    ~pos
    ~here
    ~tag:"predicate failed"
    [ Sexp.List [ Sexp.Atom "Value"; (globalize_sexp [@alloc a]) (sexpifier t) ] ]
;;

let test_pred ~pos ~sexpifier ~here ?message predicate t =
  if not (predicate t)
  then raise ((exn_test_pred [@alloc a]) ~message ~pos ~here ~sexpifier t)
;;

let[@cold] test_result_or_eq_failed ~sexpifier ~expect ~got =
  let got = (globalize_sexp [@alloc a]) (sexpifier got) in
  let expect = (globalize_sexp [@alloc a]) (sexpifier expect) in
  (match Dynamic.get r_diff with
   | None -> ()
   | Some diff ->
     let from_ = Sexp.to_string_hum expect in
     let to_ = Sexp.to_string_hum got in
     diff ~from_ ~to_);
  `Fail (expect, got)
;;

let test_result_or_eq ~sexpifier ~comparator ~equal ~expect ~got =
  let pass =
    match equal with
    | None -> comparator got expect = 0
    | Some f -> f got expect
  in
  if pass then `Pass else (test_result_or_eq_failed [@alloc a]) ~sexpifier ~expect ~got
;;

let test_eq ~pos ~sexpifier ~comparator ~here ?message ?equal t1 t2 =
  match
    (test_result_or_eq [@alloc a]) ~sexpifier ~comparator ~equal ~expect:t1 ~got:t2
  with
  | `Pass -> ()
  | `Fail (t1, t2) -> raise (exn_test_eq ~message ~pos ~here ~t1 ~t2)
;;

let[@warning "-16"] test_result
  ~pos
  ~sexpifier
  ~comparator
  ~here
  ?message
  ?equal
  ~expect
  ~got
  =
  match (test_result_or_eq [@alloc a]) ~sexpifier ~comparator ~equal ~expect ~got with
  | `Pass -> ()
  | `Fail (expect, got) -> raise (exn_test_result ~message ~pos ~here ~expect ~got)
;;]