Version française
Home     About     Download     Resources     Contact us    
Browse thread
[Caml-list] a design problem requiring downcasting? (long)
[ Home ] [ Index: by date | by threads ]
[ Search: ]

[ Message by date: previous | next ] [ Message in thread: previous | next ] [ Thread: previous | next ]
Date: -- (:)
From: tim@f...
Subject: Re: [Caml-list] a design problem requiring downcasting? (long)
Here's another stab at it.  

This is like my previous attempt, except it supports arbitrarily deep
subclassing and multiple inheritance.  This valid issue was raised by
Andreas Rossberg <rossberg@ps.uni-sb.de>.

It's like the try from "Fred Smith" <fsmith@mathworks.com>, except it
avoids polymorphism and having any central place that has to be
modified when you add a class.

This hack has uglier syntax and perhaps slower execution than
equivalent cocaml at
http://www.pps.jussieu.fr/~emmanuel/Public/Dev/coca-ml/index-en.html;
the only advantage of this hack over cocaml are a simpler compilation
environment and avoidance of Obj.magic.

The idea is to represent information about the class of the current
object as a list of exceptions.  There is one exception for each class
the current object can be downcast to.

-- 
Tim Freeman       
tim@fungible.com
GPG public key fingerprint ECDF 46F8 3B80 BB9E 575D  7180 76DF FE00 34B1 5C78 

module type Foo = sig
  exception Wrong_Class
  exception Bad_Downcast

  type 'a downcaster = exn -> 'a
  class downcastable: object
    method downcast: 'a . 'a downcaster -> 'a
  end

  class superclass: object
    inherit downcastable
    method super_meth: string
  end

  val superclass_dc: downcastable -> superclass

  class subclass_1: string -> object
    inherit superclass
    method s: string
  end
                    
  val subclass_1_dc: downcastable -> subclass_1
    
  class subclass_2: int -> object
    inherit superclass
    method i: int
  end
                    
  val subclass_2_dc: downcastable -> subclass_2

  class subsubclass:  object
    inherit subclass_1
    method j: int
  end

  val subsubclass_dc: downcastable -> subsubclass

  class multiclass: object
    inherit subclass_1
    inherit subclass_2
    method sum: int
  end
    
  val multiclass_dc: downcastable -> multiclass
    
  val x: downcastable

end

module Foo: Foo = struct

  exception Wrong_Class
  exception Bad_Downcast

  type 'a downcaster = exn -> 'a
    (** This should throw Wrong_Class if the exception isn't the one we expect,
      otherwise it should grab the argument of the exception. *)

  class downcastable = object (self)
    method private data: exn list = []
    method downcast: 'a . 'a downcaster -> 'a = fun dc ->
      let rec loop l =
        match l with
            [] -> raise Bad_Downcast
          | a :: b ->
              try
                dc a
              with
                  Wrong_Class -> loop b
      in
        loop self#data
  end

  class superclass_impl (makeexn: superclass_impl -> exn) =
  object (self: 'self)
    inherit downcastable
    method private data: exn list = [makeexn (self :> superclass_impl)]
    method super_meth: string = "superclass"
  end
            
  exception Superclass of superclass_impl

  class superclass = superclass_impl (fun sc -> Superclass sc)

  let superclass_dc (dc: downcastable): superclass =
    dc#downcast (function Superclass s -> s
                   | _ -> raise Wrong_Class)
                       
  class subclass_1_impl (s: string) (makeexn: subclass_1_impl -> exn) =
  object (self: 'self)
    inherit superclass as super
    method private data: exn list =
      makeexn (self :> subclass_1_impl) :: super#data
    method s: string = s
  end
    
  exception Subclass_1 of subclass_1_impl

  class subclass_1 (s: string) = subclass_1_impl s (fun sc -> Subclass_1 sc)
    
  let subclass_1_dc (dc: downcastable): subclass_1 =
    dc#downcast (function
                     Subclass_1 s -> s
                   | _ -> raise Wrong_Class)

  class subclass_2_impl (i: int) (makeexn: subclass_2_impl -> exn) =
  object (self: 'self)
    inherit superclass as super
    method private data: exn list =
      makeexn (self :> subclass_2_impl) :: super#data
    method i: int = i
  end
    
  exception Subclass_2 of subclass_2_impl
    
  class subclass_2 (i: int) = subclass_2_impl i (fun sc -> Subclass_2 sc)
    
  let subclass_2_dc (dc: downcastable): subclass_2 =
    dc#downcast (function
                     Subclass_2 s -> s
                   | _ -> raise Wrong_Class)

  class subsubclass_impl (makeexn: subsubclass_impl -> exn) =
  object (self: 'self)
    inherit subclass_1 "subsubclass" as super
    method private data: exn list =
      makeexn (self :> subsubclass_impl) :: super#data
    method j: int = 97
  end

  exception Subsubclass of subsubclass_impl

  class subsubclass = subsubclass_impl (fun sc -> Subsubclass sc)

  let subsubclass_dc (dc: downcastable): subsubclass =
    dc#downcast (function
                     Subsubclass s -> s
                   | _ -> raise Wrong_Class)

  class multiclass_impl (makeexn: multiclass_impl -> exn) =
  object (self: 'self)
    inherit subclass_1 "subsubclass" as super1
    inherit subclass_2 34 as super2
    method private data: exn list =
      makeexn (self :> multiclass_impl) :: (super1#data @ super2#data)
    method sum: int = String.length self#s + self#i
  end

  exception Multiclass of multiclass_impl

  class multiclass = multiclass_impl (fun sc -> Multiclass sc)

  let multiclass_dc (dc: downcastable): multiclass =
    dc#downcast (function
                     Multiclass s -> s
                   | _ -> raise Wrong_Class)

  let _ = Random.self_init ()

  let x: downcastable =
    match Random.bits () mod 5 with
        0 -> (new superclass :> downcastable)
      | 1 -> (new subclass_1 "blort" :> downcastable)
      | 2 -> (new subclass_2 17 :> downcastable)
      | 3 -> (new subsubclass :> downcastable)
      | 4 -> (new multiclass :> downcastable)
      | _ -> failwith "Impossible"  
  let _ =
    try
      Format.printf "Multiclass, sum gives %d.\n@?" (multiclass_dc x)#sum
    with Bad_Downcast -> try
      Format.printf "Subsubclass, j gives %d.\n@?" (subsubclass_dc x)#j
    with Bad_Downcast -> try
      Format.printf "Subclass_2, i gives %d.\n@?" (subclass_2_dc x)#i
    with Bad_Downcast -> try
      Format.printf "Subclass_1, s gives %s.\n@?" (subclass_1_dc x)#s
    with Bad_Downcast -> try
      Format.printf "Superclass; super_meth gives %s.\n@?"
        (superclass_dc x)#super_meth
    with Bad_Downcast ->
      failwith "Downcasts failed"
end
-------------------
To unsubscribe, mail caml-list-request@inria.fr Archives: http://caml.inria.fr
Bug reports: http://caml.inria.fr/bin/caml-bugs FAQ: http://caml.inria.fr/FAQ/
Beginner's list: http://groups.yahoo.com/group/ocaml_beginners