(* This document can be processed with
ocamlweb
to obtained a latex document.
Recommended options are:
ocamlweb --no-index --noweb exp.ml
OCaml compilation options:
ocamlc -c -w vm exp1.ml
*)
(*\section*{\label{Exp1}Module \href{exp1.ml}{Exp1}}*)
(*
This module provides a functional decomposition (operation-centric view)
of the expression problem.
\begin{quote}\em Many class type definitions and type annotations could
be omitted. We keep them to provide an early check on the interfaces of
the classes we define.
\end{quote}
*)
module FBase = struct
class type ['v] exp = object
method accept : 'v -> unit
end
class ['v] num value = object (_ : 'v #exp)
method accept v = v#visitNum value
end
class type visitor = object
method visitNum : int -> unit
end
class ['e] eval = object (self : #visitor)
val mutable result = 0
method private return x =
result <- x
method apply (t : _ #exp as 'e) =
t#accept self; result
method visitNum value =
self#return value
end
end
(* In visitors (such as eval), we used a private method [#return] to store
the result. This way the pair apply/return will work properly even if the field
[result] is shadowed. *)
module FBasePlus = struct
class type ['e] visitor = object
inherit FBase.visitor
method visitPlus : 'e -> 'e -> unit
end
class ['v] plus l r = object (_ : ('e #visitor as 'v) #FBase.exp as 'e)
method accept v =
v#visitPlus l r
end
class ['e] eval = object (self : 'e #visitor)
inherit ['e] FBase.eval
method visitPlus l r =
self#return (self#apply l + self#apply r)
end
end
module FBaseNeg = struct
class type ['e] visitor = object
inherit FBase.visitor
method visitNeg : 'e -> unit
end
class ['v] neg t = object (_ : ('e #visitor as 'v) #FBase.exp as 'e)
method accept v =
v#visitNeg t
end
class ['e] eval = object (self : 'e #visitor)
inherit ['e] FBase.eval
method visitNeg t =
self#return (- (self#apply t))
end
end
module FBasePlusNeg = struct
class type ['e] visitor = object
inherit ['e] FBasePlus.visitor
inherit ['e] FBaseNeg.visitor
end
class ['e] eval = object (self : 'e #visitor)
inherit ['e] FBasePlus.eval
inherit ['e] FBaseNeg.eval
end
end
(* The definition of class [eval] raises warnings. We can ignore them as
[result] is only used by the apply/return pair of methods. *)
module FShowPlusNeg = struct
open FBasePlusNeg
class ['e] show = object (self : 'e #visitor)
val mutable result = ""
method private return x =
result <- x
method apply (t : 'e) =
t#accept self; result
method visitNum v =
self#return (string_of_int v)
method visitPlus l r =
self#return ("("^ self#apply l ^"+"^ self#apply r ^")")
method visitNeg t =
self#return ("(-" ^ self#apply t ^")")
end
end
module FShowTest = struct
open FBase
open FBasePlusNeg
open FShowPlusNeg
let eval =
let e = new eval in
(e#apply : ('a eval exp as 'a) -> _ :> ('b visitor exp as 'b) -> _)
let show =
let s = new show in
(s#apply : ('a show exp as 'a) -> _ :> ('b visitor exp as 'b) -> _)
open FBasePlus
open FBaseNeg
let e = new plus (new neg (new plus (new num 1) (new num 2))) (new num 3)
let () = Printf.printf "%s = %d\n" (show e) (eval e)
end
(* The [eval] and [show] classes above contain the method [#apply], with
different types. Since expressions and vistors have mutually
recursive types, this would make it impossible to use both visitors
on the same expression. Fortunately, the recursion is covariant,
and we can coerce to forget the apply method in expression types. *)
(* Below, a new problem arises in class [dble], as visitors return
expressions. We can
no longer use the covariance of the recursion. We choose to make
[#apply] private, so that it no longer appears in the object type.
We can extract the [#apply] method by using an out parameter. *)
module FDblePlusNeg = struct
open FBasePlusNeg
class ['e] dble apply = object (self : 'e #visitor)
val mutable result = None
method private apply (t : 'e) : 'e =
t#accept self;
match result with Some x -> x | None -> assert false
initializer apply := self#apply
method private return x =
result <- Some x
method visitNum v =
self#return (new FBase.num (v*2))
method visitPlus l r =
self#return (new FBasePlus.plus (self#apply l) (self#apply r))
method visitNeg t =
self#return (new FBaseNeg.neg (self#apply t))
end
end
module FDbleTest = struct
open FBase
open FBasePlusNeg
open FDblePlusNeg
let dble =
let apply = ref (fun _ -> assert false) in
ignore (new dble apply);
!apply
open FShowTest
(* We reuse the expression from the previous test, multiplying nums by 2 *)
let e = dble e
let () = Printf.printf "%s = %d\n" (show e) (eval e)
end
(* We create a stub for the [#apply] method, and extract it as a
side-effect of object creation *)