Source file Speed_dsl_effect.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
module Domain = Speed_domain

type metadata = Speed_metadata.t

module type ROOT_SUITE = sig
  type t

  val root_suite : t ref
end

module Make (D : Domain.DOMAIN) (RootSuite : ROOT_SUITE with type t = unit D.t) =
struct
  open Domain.MakeFunctions (D)

  type 'a builder = {
    context: ?metadata:metadata list -> string -> ('a builder -> unit) -> unit;
    fixture:
      'b.
      ?metadata:metadata list ->
      setup:('a Domain.test_input -> 'b) ->
      string ->
      ('b builder -> unit) ->
      unit;
    test: ?metadata:metadata list -> string -> 'a D.test_function -> unit;
  }

  module MakeTypes (C : sig
      type t
    end) =
  struct
    type _ Effect.t += Op : (C.t D.t -> C.t D.t) -> unit Effect.t
  end

  let rec run : type a. (a builder -> unit) -> a D.t -> a D.t =
    fun (f : a builder -> unit) (ctx : a D.t) : a D.t ->
    let open Effect in
    let open Effect.Shallow in
    let open MakeTypes (struct
        type t = a
      end) in
    let rec loop : type c. (c, _) continuation -> c -> 'a D.t -> 'a D.t =
      fun k v ctx ->
      continue_with k v
        {
          retc= (fun _ -> ctx);
          exnc= raise;
          effc=
            (fun (type b) (eff : b Effect.t) ->
              match eff with
              | Op n -> Some (fun (k : (b, _) continuation) -> loop k () (n ctx))
              | _ -> None
            );
        }
    in
    let fixture ?metadata ~setup name specs =
      perform (Op (add_fixture ?metadata ~name ~setup @@ run specs))
    in
    let context ?metadata name specs =
      perform (Op (add_context ?metadata name (run specs)))
    in
    let test ?metadata name f = perform (Op (add_example ?metadata name f)) in

    loop (fiber f) { fixture; context; test } ctx
  ;;

  let parse (f : unit builder -> unit) = run f @@ make_suite ()
end

module Sync = Make (Domain.Sync) (Speed_dsl_list.Sync)
module LwtEffectDsl = Make (Domain.LwtDomain) (Speed_dsl_list.LwtDsl)
include Sync