Commit 59df701d authored by POTTIER Francois's avatar POTTIER Francois

Added the class [VisitorsRuntime.reduce]. Problem in the .mli file.

parent 4c906c83
module A = Array (* TEMPORARY *)
module L = List
(* -------------------------------------------------------------------------- *)
(* An exception used at arity 2 and above. *)
......@@ -9,6 +12,15 @@ let fail () =
(* -------------------------------------------------------------------------- *)
(* A virtual base class for monoids. *)
class virtual ['z] monoid = object
method private virtual zero: 'z
method private virtual plus: 'z -> 'z -> 'z
end
(* -------------------------------------------------------------------------- *)
(* Module-based packaging. *)
module Inert = struct
......@@ -312,3 +324,76 @@ class ['self] map = object
= Unit.map
end
class virtual ['self] reduce = object (self : 'self)
inherit ['z] monoid
method visit_array: 'env 'a .
('env -> 'a -> 'z) -> 'env -> 'a array -> 'z
= fun f env xs ->
A.fold_left (fun z x -> self#plus z (f env x)) self#zero xs
method visit_bool: 'env .
'env -> bool -> 'z
= fun _env _ -> self#zero
method visit_char: 'env .
'env -> char -> 'z
= fun _env _ -> self#zero
method visit_float: 'env .
'env -> float -> 'z
= fun _env _ -> self#zero
method visit_int: 'env .
'env -> int -> 'z
= fun _env _ -> self#zero
method visit_int32: 'env .
'env -> int32 -> 'z
= fun _env _ -> self#zero
method visit_int64: 'env .
'env -> int64 -> 'z
= fun _env _ -> self#zero
method visit_list: 'env 'a .
('env -> 'a -> 'z) -> 'env -> 'a list -> 'z
= fun f env xs ->
L.fold_left (fun z x -> self#plus z (f env x)) self#zero xs
method visit_option: 'env 'a .
('env -> 'a -> 'z) -> 'env -> 'a option -> 'z
= fun f env ox ->
match ox with
| Some x ->
f env x
| None ->
self#zero
method visit_ref: 'env 'a .
('env -> 'a -> 'z) -> 'env -> 'a ref -> 'z
= fun f env rx ->
f env !rx
method visit_result: 'env 'a 'e .
('env -> 'a -> 'z) ->
('env -> 'e -> 'z) ->
'env -> ('a, 'e) result -> 'z
= fun f g env r ->
match r with
| Ok a ->
f env a
| Error b ->
g env b
method visit_string: 'env .
'env -> string -> 'z
= fun _env _ -> self#zero
method visit_unit: 'env .
'env -> unit -> 'z
= fun _env _ -> self#zero
end
......@@ -2,6 +2,15 @@ exception StructuralMismatch
val fail: unit -> 'a
(* -------------------------------------------------------------------------- *)
(* A virtual base class for monoids. *)
class virtual ['z] monoid : object
method private virtual zero: 'z
method private virtual plus: 'z -> 'z -> 'z
end
module Inert : sig
val iter: 'env -> 'a -> unit
val map: 'env -> 'a -> 'a
......@@ -201,3 +210,50 @@ class ['self] map : object
'env -> unit -> unit
end
class virtual ['self] reduce : object
inherit ['z] monoid
method visit_array: 'env 'a .
('env -> 'a -> 'z) -> 'env -> 'a array -> 'z
method visit_bool: 'env .
'env -> bool -> 'z
method visit_char: 'env .
'env -> char -> 'z
method visit_float: 'env .
'env -> float -> 'z
method visit_int: 'env .
'env -> int -> 'z
method visit_int32: 'env .
'env -> int32 -> 'z
method visit_int64: 'env .
'env -> int64 -> 'z
method visit_list: 'env 'a .
('env -> 'a -> 'z) -> 'env -> 'a list -> 'z
method visit_option: 'env 'a .
('env -> 'a -> 'z) -> 'env -> 'a option -> 'z
method visit_ref: 'env 'a .
('env -> 'a -> 'z) -> 'env -> 'a ref -> 'z
method visit_result: 'env 'a 'e .
('env -> 'a -> 'z) ->
('env -> 'e -> 'z) ->
'env -> ('a, 'e) result -> 'z
method visit_string: 'env .
'env -> string -> 'z
method visit_unit: 'env .
'env -> unit -> 'z
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment