From mboxrd@z Thu Jan  1 00:00:00 1970
Return-Path: <Tiphaine.Turpin@free.fr>
X-Spam-Checker-Version: SpamAssassin 3.1.3 (2006-06-01) on yquem.inria.fr
X-Spam-Level: 
X-Spam-Status: No, score=0.0 required=5.0 tests=none autolearn=disabled 
	version=3.1.3
X-Original-To: caml-list@yquem.inria.fr
Delivered-To: caml-list@yquem.inria.fr
Received: from mail3-relais-sop.national.inria.fr (mail3-relais-sop.national.inria.fr [192.134.164.104])
	by yquem.inria.fr (Postfix) with ESMTP id B43EFBBCB
	for <caml-list@yquem.inria.fr>; Wed, 27 Feb 2008 14:30:10 +0100 (CET)
X-IronPort-Anti-Spam-Filtered: true
X-IronPort-Anti-Spam-Result: AgAAAC71xEfAXQInh2dsb2JhbACQZwEBAQgKKZxV
X-IronPort-AV: E=Sophos;i="4.25,413,1199660400"; 
   d="scan'208";a="9650763"
Received: from concorde.inria.fr ([192.93.2.39])
  by mail3-smtp-sop.national.inria.fr with ESMTP; 27 Feb 2008 14:30:10 +0100
Received: from mail3-relais-sop.national.inria.fr (mail3-relais-sop.national.inria.fr [192.134.164.104])
	by concorde.inria.fr (8.13.6/8.13.6) with ESMTP id m1RDU5gm010785
	(version=TLSv1/SSLv3 cipher=RC4-SHA bits=128 verify=OK)
	for <caml-list@inria.fr>; Wed, 27 Feb 2008 14:30:10 +0100
X-IronPort-AV: E=Sophos;i="4.25,413,1199660400"; 
   d="scan'208";a="9650760"
Received: from arvin.irisa.fr (HELO [131.254.11.86]) ([131.254.11.86])
  by mail3-relais-sop.national.inria.fr with ESMTP/TLS/DHE-RSA-AES256-SHA; 27 Feb 2008 14:30:10 +0100
Message-ID: <47C564EA.4060902@free.fr>
Date: Wed, 27 Feb 2008 14:26:02 +0100
From: "Tiphaine.Turpin" <Tiphaine.Turpin@free.fr>
User-Agent: Thunderbird 1.5.0.10 (X11/20070303)
MIME-Version: 1.0
To: Caml-list List <caml-list@inria.fr>
Subject: Re: [Caml-list] Objects, dynamic cast, Obj.magic abuse and dragons
References: <47C3F96E.4080901@exalead.com> <20080226121451.GA20860@annexia.org>
In-Reply-To: <20080226121451.GA20860@annexia.org>
Content-Type: text/plain; charset=ISO-8859-1; format=flowed
Content-Transfer-Encoding: 8bit
X-Miltered: at concorde with ID 47C565DD.000 by Joe's j-chkmail (http://j-chkmail . ensmp . fr)!
X-Spam: no; 0.00; parametric:01 scalable:01 lablgtk:01 val:01 hashtbl:01 hashtbl:01 gtk:01 'self:01 'self:01 syntactic:01 exception:01 exception:01 caml-list:01 inherit:01 inherit:01 

Here is another try. it has the drawback that classes need to be 
parametric, but it seems to work, and to be scalable (the added code is 
always the same). Of course, some syntactic sugar would help.

Tiphaine Turpin

Richard Jones a écrit :
> I only briefly read over this, but maybe the thing you want is an
> object memo.  There's a specialized one in lablgtk called GUtil.memo,
> but the basic source for it could be adapted:
>
>   class ['a] memo () = object
>     constraint 'a = #widget
>     val tbl = Hashtbl.create 7
>     method add (obj : 'a) =
>       Hashtbl.add tbl obj#get_id obj
>     method find (obj : widget) = Hashtbl.find tbl obj#get_id
>     method remove (obj : widget) = Hashtbl.remove tbl obj#get_id
>   end
>
> There's an example of using this if you search down for 'memo' on this
> page:
>
>   http://www.ocaml-tutorial.org/introduction_to_gtk
>
> Rich.
>
>   
#load "extLib.cma"

open ExtList
exception Class_cast_exception

let cast f o =
  match List.filter_map f o#supers with
    | [] -> raise Class_cast_exception
    | o' :: _ -> o'

class ['super] a = object (self : 'self)
  method supers : 'super list = [`a (self :> _ a)]
  method a = ()
end

class ['super] b = object (self : 'self)
  inherit ['super] a as a
  method supers = `b (self :> _ b) :: a#supers
  method b = ()
end

class ['super] c = object (self : 'self)
  inherit ['super] a as a
  method supers = `c (self :> _ c) :: a#supers
  method c = ()
end

class ['super] d = object (self : 'self)
  inherit ['super] b as b
  inherit ['super] c as c
  method supers =  `d (self :> _ d) :: b#supers @ c#supers
  method d = ()
end

class ['super] e = object (self : 'self)
  inherit ['super] d as d
  method supers = `e (self :> _ e) :: d#supers
  method e = ()
end

let d = (new d :> _ a)
let a : _ a = cast (function `a o -> Some o | _ -> None) d
let b : _ b = cast (function `b o -> Some o | _ -> None) d
let c : _ c = cast (function `c o -> Some o | _ -> None) d
let d : _ d = cast (function `d o -> Some o | _ -> None) d

let c = new c
let error : _ b = cast (function `b o -> Some o | _ -> None) c