Ah, I just realized. Indeed it is!
Binding operators for resource management:
type _ resource =
| File : (string * Unix.open_flag list * Unix.file_perm) -> Unix.file_descr resource
| Lock : unit resource
let ( let* ) : type a. a resource -> (a -> 'b) -> 'b = fun v f ->
match v with
| Lock ->
ignore () (* lock *);
let r = f () in
ignore () (*release *);
r
| File (fname, flags, perms) ->
let d = Unix.openfile fname flags perms in
let r = f d in
let () = Unix.close d in
r
This is obviously incomplete. The lock needs actual locking mechanism. The file resource handler needs some error management. Still, as a proof of concept, it works:
# let* d = File ("/tmp/foo", Unix.[O_CREAT; O_WRONLY], 0o640) in
Unix.write_substring d "THIS" 0 4 ;;
- : int = 4
Binding operators for rolling dice (or how to DSL with let*)
You can do a lot in the body of the ( let* ) definition, including interpreting the bound expression in some way.
let ( let* ) v f = f (Random.int v + 1)
Arguably, the code is more readable by including some text:
let ( let* ) (`Roll v) f = f (Random.int v + 1)
Or even with a DSL (in this example using GitHub - raphael-proust/odds: OCaml Dice Dice Something: a library and program to roll dice)
let ( let* ) v f =
let v = Odds.roll (Odds_parser.t_of_string v) in
f v
let* r = "2d6 + 1d8" in print_int r
EDIT: obvious use-case: compiling regular expressions let ( let/ ) re f = let re = Str.regexp re in f re
3 Likes
Poor man’s effect handlers:
type 'a t = ..
type 'b handler = {f: 'a . 'a t * ('a -> 'b) -> 'b option}
type 'a ctx = {perform: 'b . 'b t -> ('b -> 'a) -> 'a}
let run_with_handlers (type a) handlers =
let exception Eff: 'a t * ('a -> a) -> exn in
let perform (type b) (vl: b t) (cont: b -> a) : a = raise (Eff (vl, cont)) in
let ctx = {perform} in
fun (f: (a ctx) -> 'c -> a) (args: 'c) ->
let rec run (f: unit -> a) =
try
f ()
with Eff (op, cont) ->
let kont value = run (fun () -> cont value) in
let value = List.find_map (fun {f} -> f (op, kont)) handlers |> Option.get in
value in
run (fun () -> f ctx args)
type _ t += ReadInt : int t
type _ t += ReadString : string t
let (let+) x kont = x kont
let helper_comp {perform} kont =
let+ num1 = perform ReadInt in
let+ num2 = perform ReadInt in
kont (num1, num2)
let computation {perform} kont =
let+ num1 = perform ReadInt in
let+ num2 = perform ReadInt in
let+ (num3,num4) = helper_comp {perform} in
let+ str = perform ReadString in
kont ("received " ^ Int.to_string (num1 + num2) ^ " and " ^ str ^ " and " ^
Int.to_string num3 ^ ", " ^ Int.to_string num4)
let saved_handler : (int -> string) ref = ref @@ fun _ -> ""
let my_handler =
let handle (type a) (vl: a t * (a -> 'b)) : 'b option = match vl with
| ReadInt, kont -> saved_handler := kont; let x = read_int () in Some (kont x)
| ReadString, kont -> let x = read_line () in Some (kont x)
| _ -> None in
{f=handle}
let vl = run_with_handlers [my_handler] computation (fun x -> x)
let _ =
print_string vl;
print_string (!saved_handler 10);
(edit: now supports multiple effects)
(edit2: simplified the types)
(edit3: added multi-shot handlers)
2 Likes
recently I started an OCaml 
implementation accessing djb’s cdb file format:
(* http://cr.yp.to/cdb/cdb.txt
*
* Compiler and runtime failure if int <= 31 bit.
*
* May get dependencies to Optint and Cstruct.
*)
module Cdb = struct
(* hash them all. http://cr.yp.to/cdb/cdb.txt *)
let hash (byt : bytes) : int =
let len = byt |> Bytes.length
and ( << ) = Int.shift_left
and ( ^ ) = Int.logxor in
let rec fkt idx h =
match idx = len with
| true -> h
| false ->
let c = idx |> Bytes.get byt |> Char.code in
(((h << 5) + h) ^ c) land 0xFFffFFff |> fkt (idx + 1)
in
fkt 0 5381
(*
* Find data of first record for the key.
* Leaves the file-pointer behind the hit.
*
* http://cr.yp.to/cdb/cdb.txt
*)
let first fd (key : bytes) : bytes option =
(* let uint _ cs off =
off |> Cstruct.LE.get_uint32 cs |> Int32.unsigned_to_int |> Option.get
*)
let uint buf off =
let ( << ) = Int.shift_left in
let le idx = off + idx |> Bytes.get buf |> Char.code << idx * 8 in
le 0 lor le 1 lor le 2 lor le 3 land 0xFFffFFff
in
let len = 2 * 4 (* two uint32 *) in
let buf = len |> Bytes.create (* re-used multiple times *) in
let ha = key |> hash in
(* Printf.printf "h = %d\n" ha; *)
(* Printf.printf "p = %d\n" (ha mod 256); *)
let _ = Unix.lseek fd (ha mod 256 * len) Unix.SEEK_SET in
match len = (len |> Unix.read fd buf 0) with
| false -> None
| true -> (
(* let cs = buf |> Cstruct.of_bytes ~len in *)
match (uint buf 0, uint buf 4) with
| _, 0 -> None
| hpos, hcnt -> (
(* hash table file position and entry count *)
(* Printf.printf "hpos, hcnt = %d, %d\n" hpos hcnt; *)
let rec rec_pos slot =
(* Printf.printf "i = %d\n" i; *)
match slot < hcnt with
| false -> 0 (* file inconsistent *)
| true -> (
let _ = Unix.lseek fd (hpos + (slot * len)) Unix.SEEK_SET in
match len = (len |> Unix.read fd buf 0) with
| false -> 0 (* I/O error *)
| true -> (
(* let cs' = buf |> Cstruct.of_bytes ~len in *)
match (uint buf 0, uint buf 4) with
| _, 0 ->
(* Printf.printf "slot %d empty\n" s'; *)
0
| hval, rpos -> (
(* Printf.printf "hval, rpos = %d, %d\n" hval rpos; *)
match ha = hval with
| true -> rpos
| false -> rec_pos (slot + 1))))
in
match ha / 256 mod hcnt |> rec_pos with
| 0 -> None
| rpos ->
let _ = Unix.lseek fd rpos Unix.SEEK_SET in
let kl0 = key |> Bytes.length in
let kbuf = kl0 |> Bytes.create in
let rec recy i =
match len = (len |> Unix.read fd buf 0) with
| false -> None (* I/O error *)
| true -> (
(* let cs' = buf |> Cstruct.of_bytes ~len in *)
let klen, dlen = (uint buf 0, uint buf 4) in
(* Printf.printf "klen, dlen = %d, %d\n" klen dlen; *)
match
klen = kl0 && kl0 = (kl0 |> Unix.read fd kbuf 0)
with
| false -> None (* consistency or I/O error *)
| true -> (
match key |> Bytes.equal kbuf with
| true -> (
let dbuf = dlen |> Bytes.create in
match dlen = (dlen |> Unix.read fd dbuf 0) with
| false -> None (* I/O error *)
| true -> Some dbuf)
| false -> (
match ha = (kbuf |> hash) with
| false -> None
| true ->
let _ = Unix.lseek fd dlen Unix.SEEK_CUR in
recy (i + 1))))
in
recy 0))
end
I didn’t mmap to leverage the file-pointer as state for a possible next()
1 Like
Yet another (ab)?use of the let-binding operators, now for the generalized pattern matching. Suppose we have some hierarchy of types and a value that has the base type, which we want to downcast and perform some operation available in the downcasted types. Usually, we will represent this with pattern matching, but what can we do if the type is not an ADT? Let’s use the let-binding operator let|, like this,
and here is the implementation, it can be generalized, of course to any type, just substitute resort with any non-total function,
3 Likes