GADTs in OCaml, part 2

kleislist.ml

module type Monad = sig

	type 'a m

	val bind : 'a m -> ('a -> 'b m) -> 'b m

	val return: 'a -> 'a m

end

module Kleislist(T: Monad) = struct

	open T

	type _ kleislist =
	| Id : ('a * 'a) kleislist
	| Cons : ('a -> 'b m) * ('b * 'c) kleislist -> ('a * 'c) kleislist

	let rec length : type a . a kleislist -> int = function
	| Id -> 0
	| Cons (_, xs) -> 1 + length xs

	let rec compose : type a b . (a * b) kleislist -> (a -> b m) = function
	| Id -> (fun x -> return x)
	| Cons (f, xs) -> (fun x -> bind (f x) (compose xs))

	let (^:) a b = Cons (a, b)

	let rec concat : type a b c . ((a * b) kleislist * (b * c) kleislist) -> (a * c) kleislist = function
	| (Id, ys) -> ys
	| (Cons (f, xs), ys) -> f ^: concat (xs, ys)

	let (@:) a b = concat (a, b)

end

module OptionM = struct

	type 'a m = 'a option

	let bind x f = match x with
	| None -> None
	| Some x -> f x

	let return x = Some x

end

module K = Kleislist(OptionM)
open K

let f1 (x : int) = Some (x + 1)

let f2 (x : int) = if x >= 9000 then Some (string_of_int x) else None

let f3 (x : string) = Some ("It's over " ^ x)

let clist = f1 ^: f2 ^: f3 ^: Id

let string_of_option = function
| None -> "None"
| Some x -> "Some(" ^ x ^ ")"

let _ =
  print_endline (string_of_option (compose clist 8999));
  print_endline (string_of_option (compose clist 8998));;