slit-tulip.ml

(* type 'a succ *)



module Slit = struct
  type zero
  type 'a succ = X

  type (_, _) t =
    | [] : ('a, zero) t
    | (::) : 'a * ('a, 'length) t -> ('a, 'length succ) t

  type ('a, 'length) non_empty = ('a, 'length succ) t


  let head (head :: tail) = head
  let tail (head :: tail) = tail


  let x = [1;2;3]

  let rec zip : type a b length. (a, length) t -> (b, length) t -> (a * b, length) t = fun left right ->
    match left, right with
    | [], [] -> []
    | left_head :: left_tail, right_head :: right_tail ->
        (left_head, right_head) :: zip left_tail right_tail

  let rec map : type a b length. (a -> b) -> (a, length) t -> (b, length) t = fun f -> function
    | [] -> []
    | head :: tail -> f head :: map f tail
end

type _ tulip =
  | [] : unit tulip
  | (::) : 'a * 'b tulip -> ('a * 'b) tulip

module type TULIP = sig
  type _ t

  val first : ('a * 'b) t -> 'a
  val second : ('a * ('b * 'c)) t -> 'b
  val third : ('a * ('b * ('c * 'd))) t -> 'c

  val unit : unit t
  val pair : 'a -> 'b -> ('a * ('b * unit)) t
  val triple : 'a -> 'b -> 'c -> ('a * ('b * ('c * unit))) t

  val prepend : 'a -> 'b t -> ('a * 'b) t
end


module Tulip : TULIP with type 'a t = 'a tulip = struct
  type 'a t = 'a tulip

  let first  (x :: _) = x
  let second (_ :: x :: _) = x
  let third  (_ :: _ :: x :: _) = x

  let unit = []
  let pair a b = [a; b]
  let triple a b c = [a; b; c]

  let prepend head tail = head :: tail
end

let () =
  (* equality *)
  assert (Tulip.[1; "a"; `b] = Tulip.[1; "a"; `b]);
  assert (Tulip.[9; "x"; `z] <> Tulip.[1; "a"; `b]);
  assert (Tulip.[9.0; "x"; `z] <> Tulip.[1.0; "a"; `b]);

  (* pattern-matching *)
  assert begin
    match Tulip.[true; "a"; `b] with
    | Tulip.[true; _; _] -> true
    | Tulip.(false :: _) -> false
  end;

  (* first/second *)
  assert (Tulip.(first [`a; `b]) = `a);
  assert (Tulip.(second [1; 2]) = 2);

  (* prepend *)
  assert (Tulip.(`a :: [`b]) = Tulip.[`a; `b]);

  print_endline " -- ok -- "






module Flat_tulip : TULIP = struct
  type _ t = int array

  let first  t = Obj.magic (Array.unsafe_get t 0)
  let second t = Obj.magic (Array.unsafe_get t 1)
  let third  t = Obj.magic (Array.unsafe_get t 2)

  let unit = [||]
  let pair a b = [|Obj.magic a; Obj.magic b|]
  let triple a b c = [|Obj.magic a; Obj.magic b; Obj.magic c|]

  let prepend head tail = Array.append [|Obj.magic head|] tail

end


let () =
  (* equality *)

  let open Flat_tulip in
  let (^) = prepend in

  assert ((1 ^ "a" ^ `b ^ unit) = (1 ^ "a" ^ `b ^ unit));
  assert ((9 ^ "a" ^ `b ^ unit) <> (1 ^ "a" ^ `b ^ unit));
(*   assert ((1.0 ^ "a" ^ `b ^ unit) = (1.0 ^ "a" ^ `b ^ unit)); *)

  (* first/second *)
  assert (first (pair `a `b) = `a);
  assert (second (pair 1 2) = 2);

  (* prepend *)
  assert (`a ^ `b ^ unit = pair `a `b);

  print_endline " -- ok -- "