Version française
Home     About     Download     Resources     Contact us    

This site is updated infrequently. For up-to-date information, please visit the new OCaml website at

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 <>.

It's like the try from "Fred Smith" <>, 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;
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
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

  class superclass: object
    inherit downcastable
    method super_meth: string

  val superclass_dc: downcastable -> superclass

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

  class subsubclass:  object
    inherit subclass_1
    method j: int

  val subsubclass_dc: downcastable -> subsubclass

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


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 ->
                dc a
                  Wrong_Class -> loop b
        loop self#data

  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"
  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
  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
  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

  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

  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 _ =
      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"
To unsubscribe, mail Archives:
Bug reports: FAQ:
Beginner's list: