Skip to content

Instantly share code, notes, and snippets.

let[@tail_mod_cons] rec split escape_char char start pos s =
if pos >= String.length s then
[String.sub s start (String.length s - start)]
else
let c = s.[pos] in
if c = char then
(String.sub s start (pos-start)) :: split escape_char char (pos+1) (pos+1) s
else
let pos = if c = escape_char then pos + 2 else pos + 1 in
split escape_char char start pos s
module Url = struct let v2 = "v2" end
let fwd_v2 target = (target, Url.v2 ^ target)
let pp_ocaml_version ppf (mj, mn) =
if mj >= 5 then Format.fprintf ppf "%d.%d" mj mn
else Format.fprintf ppf "%d.%02d" mj mn
let notes_redirections v =
let fwd_v2_notes x =
@Octachron
Octachron / contravariance_constraint.ml
Created August 18, 2023 12:07
Contravariance and type equations
module type pair = sig type a type b end
module type S = functor (Pair:sig include pair type b = a end) -> sig
open Pair
type either = Left of a | Right of b
end
module R = struct
type a = A
type b = a
module Unit: sig
type 'a t
val magic: 'a t -> 'b t
type m type s
val m: m t
val s: s t
val (+): 'a t -> 'a t -> 'a t
val ( * ): 'a t -> 'b t -> ('a * 'b) t
end = struct
type 'a t =float
@Octachron
Octachron / extensible_calculi.ml
Created July 12, 2023 12:34
extensible Calculi
type _ calculi_register = ..
type 'a c =
| Core of 'a
| Ext: 'b calculi_register *'b -> 'a c
type mixed_eval = { eval: 'a. 'a calculi_register -> 'a -> 'a c }
module type ext_calculus = sig
type core
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
Octachron / hlist_and_format.ml
Created June 15, 2023 14:25
Hlist for format printing
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
| [] -> ()
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
Octachron / chain_compare.ml
Created June 1, 2023 09:09
Efficient comparison chaining
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
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