(* Copyright (C) 2003 Julien SIGNOLES *)

(*
 *          --unroll-->
 *       U               U -> U
 *          <---roll---
 *)
module type AutoType = sig
  type t
  val roll   : (t -> t) -> t
  val unroll : t -> t -> t
end

(* 
 * application : codage lambda-calcul pur
 *
 * t(x)          = x
 * t(lambda x.a) = roll (fun x -> t(a))
 * t(a1 a2)      = unroll t(a1) t(a2)
 *
 * n'importe quelle application du foncteur [Lambda] va dans les choux !
 *)
module Lambda(A : AutoType) = struct
  (* Codage de Jean-Christophe *)
  let delta = A.roll (fun x -> (A.unroll x x))
  let omega = A.unroll delta delta
    (* et hop... dans les choux ! *)
end

module Exception : AutoType = struct
  (* Codage Jean-Christophe *)
  type t       = unit -> unit
  exception Hide of (t -> t)
  let roll   x = fun _ -> raise (Hide x)
  let unroll x = try (fun () y -> y) (x ()) with Hide y -> y
end

module Reference : AutoType = struct
  (* Codage Jean-Christophe *)
  type t       = unit -> unit
  let hide     = ref (fun x -> x)
  let roll   x = fun _ -> hide := x
  let unroll x = x (); !hide
end

module Somme : AutoType = struct
  type t              = Hide of (t -> t)
  let roll   x        = Hide x
  let unroll (Hide x) = x
end

module Variant : AutoType = struct
  (* on pourrait se passer du type, mais il faut respecter la signature.
     Version courte a la fin du fichier. *)
  type t               = [ `Hide of t -> t ]
  let roll   x         = `Hide x
  let unroll (`Hide x) = x
end

module Record : AutoType = struct
  type t       = { hide : t -> t }
  let roll   x = { hide = x }
  let unroll x = x.hide
end

module Object : AutoType = struct
  class t    x = object method hide (x:t) = x end
  let roll   x = new t x
  let unroll x = x#hide
end

(* version qui triche un peu ;-) *)
module Magic : AutoType = struct
  type t       = Obj.t
  let roll   x = Obj.repr x
  let unroll x = Obj.obj x
end

(* version un peu sale sur les bords (voir au milieu) ;-) *)
module AbstractIdentity : AutoType = struct
  type t            (* abstrait ! *)
  type u = t -> t
  external roll   : u -> t = "%identity"
  external unroll : t -> u = "%identity"
end
(*
(* avec l'option -rectypes, le codage est direct... *)
module RecTypes : AutoType = struct
  type t       = t -> t
  let roll   x = x
  let unroll x = x
end
*)
module Lam_Exc = Lambda(Exception)
module Lam_Ref = Lambda(Reference)
module Lam_Sum = Lambda(Somme) 
module Lam_Var = Lambda(Variant)
module Lam_Rec = Lambda(Record)
module Lam_Obj = Lambda(Object)
module Lam_Mag = Lambda(Magic)
module Lam_AId = Lambda(AbstractIdentity);;
(*module Lam_ReT = Lambda(RecTypes);;*)

(* version la plus courte (que j'ai trouvee) de omega. *)
let d(`H x)=x(`H x)in d(`H d);;