(* This document can be processed with
ocamlweb <http://www.lri.fr/~filliatr/ocamlweb/>
to obtained a latex document.

Recommended options are: 

        ocamlweb --no-index --short --noweb exp.ml exp1.ml exp2.ml

OCaml compilation options: 

        ocamlc -c -w vm exp2.ml
*)

(*\section*{\label{Exp2}Module \href{exp2.ml}{Exp2}}*)
(* This is another approach to the functional decompsition of the expression problem. 

Rather than using coercions later, we hide the [#apply] method from
the beginning. All visitors inherit from [accumulators], and are
called via [extract] *)

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
  (* [f] is an out parameter *)
  class virtual ['a,'e] accumulator f = object (self : 's)
    val mutable result = None
    method private return x =
      result <- Some x
    method private apply (t : 's #exp as 'e) =
      t#accept self;
      match result with Some x -> x | None -> assert false
    initializer f := self#apply
  end
  class ['e] eval f = object (self)
    inherit [int,'e] accumulator f
    method visitNum value =
      self#return value
  end
  let extract cons =
    let f = ref (fun _ -> assert false) in
    cons f; !f
  (* We could use this as [let eval = extract (new eval)] *)
end

module FBasePlus = struct
  class ['e] eval f = object (self)
    inherit ['e] FBase.eval f
    method visitPlus l r =
      self#return (self#apply l + self#apply r)
  end
  (* Since we have hidden [#apply], [#eval] is the same as [#visitor] *)
  class ['v] plus l r = object (_ : ('e #eval as 'v) #FBase.exp as 'e)
    method accept v =
      v#visitPlus l r
  end
end

module FBaseNeg = struct
  class ['e] eval f = object (self)
    inherit ['e] FBase.eval f
    method visitNeg t =
      self#return(- (self#apply t))
  end
  class ['v] neg t = object (_ : ('e #eval as 'v) #FBase.exp as 'e)
    method accept v =
      v#visitNeg t
  end
end

module FBasePlusNeg = struct
  class ['e] eval f = object (self)
    inherit ['e] FBasePlus.eval f
    inherit ['e] FBaseNeg.eval f
  end
end

module FShowPlusNeg = struct
  open FBasePlusNeg
  class ['e] show f = object (self)
    inherit [string,'e] FBase.accumulator f
    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 = extract (new eval)
  let show = extract (new show)

  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

module FDblePlusNeg = struct
  class ['e] dble f = object (self)
    inherit ['e,'e] FBase.accumulator f
    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 = extract (new dble)

  open FShowTest
  let e = dble e
  let () = Printf.printf "%s = %d\n" (show e) (eval e)
end