Octachron

let maybe_reduce
    (MonoidElement.Constructor ((module Monoid1) as monoid1, element1))
    (MonoidElement.Constructor ((module Monoid2) as monoid2, element2)) =
    let element1_is_unit = Monoid1.eq element1 Monoid1.unit in
    let element2_is_unit = Monoid2.eq element2 Monoid2.unit in
    let same_monoid = Type_equal.Id.same_witness Monoid1.t Monoid2.t in
    match element1_is_unit, element2_is_unit, same_monoid with
    | true, _, _ -> Reduced (MonoidElement.Constructor (monoid2, element2))
    | _, true, _ -> Reduced (MonoidElement.Constructor (monoid1, element1))
    | _, _, Some eq ->

Octachron

module L = struct
  type 'args t =
    | [] : unit t
    | (::): 'a * 'b t -> ('a -> 'b) t
end

let rec print_list: type args result.
  Format.formatter -> args -> args L.t -> unit  =
  fun ppf print -> function
    | [] -> ()

Octachron

type ('a,'b,'c) skel =
| A of 'a
| B of 'b
| C of 'c

type 'a disabled = |
type 'a enabled = 'a

module Make(X:sig type 'a a type 'a b type 'a c end) = struct
   type ('a,'b,'c) t = ('a X.a, 'b X.b, 'c X.c) skel

Octachron

type _ compare =
| Int: int compare
| Float: float compare
| Poly: 'a compare

let[@inline always] typed_compare (type a) (w:a compare) (x:a) (y:a) =
match w with
| Int -> Stdlib.compare (x:int) (y:int)
| Float -> Stdlib.compare (x:float) (y:float)
| Poly -> Stdlib.compare x y

Octachron

let with_timeout timeout (f:unit -> 'b) =
  let read, write = Unix.pipe () in
  match Unix.fork () with
  | 0 ->
    let result = f () in
    let chan = Unix.out_channel_of_descr write in
    Marshal.to_channel  chan result [];
    Out_channel.flush chan;
    Unix.close write;
    exit 0

Octachron

type t = < count: int >

let leak: t option Atomic.t = Atomic.make None

let stop = Atomic.make false


class virtual counter = object(self)
   val mutable counter = -1
   method count = counter

Octachron

let device_flush ppf =
  let fs = Format.pp_get_formatter_out_functions ppf () in
  fs.out_flush ()

let force_break_hints ppf =
  let margin = Format.pp_get_margin ppf () in
  Format.pp_print_as ppf (margin+1) ""

let gentler_flush ppf =
  force_break_hints ppf; device_flush ppf

Octachron

type 'a abstract
sig
  type 'a x = X
  type 'a t = A: 'a -> 'a x t
end with type 'a x = 'a abstract

Octachron

type 'a printer = Format.formatter -> 'a -> unit
type 'a rand =  unit -> 'a

let flushed_list pr ppf x =
  List.iter (Format.fprintf ppf "%a@." pr) x


module type testable = sig
  type t
  val pp: t printer

Octachron

type _ data_cstr = ..

module type t = sig
  type a
  type _ data_cstr += Fmt: a data_cstr
end

type 'a data_format = (module t with type a = 'a)

let mk_data_format : type a. unit -> a data_format = fun () ->