Глава 5. Дополнительные примеры классов и модулей

В этой главе приведены более масштабные примеры использования классов, объектов и модулей. При разработке банковского счета задействованы многие возможности объектов. В главе показано, как модули стандартной библиотеки используются в качестве классов. В конце главы на примере оконных менеджеров описывается шаблон проектирования, известный как виртуальные типы.

5.1 Банковский счет

В этом разделе иллюстрируются особенности объектов и наследования на примере уточнения, отладки и специализации первоначального грубого определения банковского счета (повторно используется модуль Euro, разработанный в конце главы 3).

#let euro = new Euro.c;;

val euro : float -> Euro.c = <fun>

#let zero = euro 0.;;

val zero : Euro.c = <obj>

#let neg x = x#times (-1.);;

val neg : < times : float -> 'a; .. > -> 'a = <fun>

#class account =
   object 
     val mutable balance = zero
     method balance = balance
     method deposit x = balance <- balance # plus x
     method withdraw x =
       if x#leq balance then (balance <- balance # plus (neg x); x) else zero
   end;;

class account :
  object
    val mutable balance : Euro.c
    method balance : Euro.c
    method deposit : Euro.c -> unit
    method withdraw : Euro.c -> Euro.c
  end

#let c = new account in c # deposit (euro 100.); c # withdraw (euro 50.);;

- : Euro.c = <obj>

Теперь мы расширим класс, добавив метод для вычисления процентов.

#class account_with_interests =
   object (self)
     inherit account
     method private interest = self # deposit (self # balance # times 0.03)
   end;;

class account_with_interests :
  object
    val mutable balance : Euro.c
    method balance : Euro.c
    method deposit : Euro.c -> unit
    method private interest : unit
    method withdraw : Euro.c -> Euro.c
  end

Метод interest объявлен как приватный, поскольку он, очевидно, не должен вызываться извне. Таким образом он доступен лишь для субклассов, которые ежемесячно или ежегодно будут обновлять счет.

Кроме того, стоит исправить ошибку в текущем определении: методом deposit можно снимать деньги, положив на счет отрицательную сумму. Это просто:

#class safe_account =
   object
     inherit account
     method deposit x = if zero#leq x then balance <- balance#plus x
   end;;

class safe_account :
  object
    val mutable balance : Euro.c
    method balance : Euro.c
    method deposit : Euro.c -> unit
    method withdraw : Euro.c -> Euro.c
  end

Однако есть и более тонкий способ исправить ошибку:

#class safe_account =
   object
     inherit account as unsafe
     method deposit x =
       if zero#leq x then unsafe # deposit x
       else raise (Invalid_argument "deposit")
   end;;

class safe_account :
  object
    val mutable balance : Euro.c
    method balance : Euro.c
    method deposit : Euro.c -> unit
    method withdraw : Euro.c -> Euro.c
  end

В этом случае не требуеся знать реализацию метода deposit.

Ради возможности отслеживать операции со счетом в класс добавляется изменяемая переменная history и приватный метод trace, помещающий в журнал запись об операции. Кроме того, все журналируемые методы переопределяются.

#type 'a operation = Deposit of 'a | Retrieval of 'a;;

type 'a operation = Deposit of 'a | Retrieval of 'a

#class account_with_history =
   object (self) 
     inherit safe_account as super  
     val mutable history = []
     method private trace x = history <- x :: history
     method deposit x = self#trace (Deposit x);  super#deposit x
     method withdraw x = self#trace (Retrieval x); super#withdraw x
     method history = List.rev history
   end;;

class account_with_history :
  object
    val mutable balance : Euro.c
    val mutable history : Euro.c operation list
    method balance : Euro.c
    method deposit : Euro.c -> unit
    method history : Euro.c operation list
    method private trace : Euro.c operation -> unit
    method withdraw : Euro.c -> Euro.c
  end

Может возникнуть потребность одновременно открыть счет и перевести на него некоторую сумму. Первоначальное определение не позволяет это делать, но проблема решается с помощью инициализатора:

#class account_with_deposit x =
   object 
     inherit account_with_history 
     initializer balance <- x 
   end;;

class account_with_deposit :
  Euro.c ->
  object
    val mutable balance : Euro.c
    val mutable history : Euro.c operation list
    method balance : Euro.c
    method deposit : Euro.c -> unit
    method history : Euro.c operation list
    method private trace : Euro.c operation -> unit
    method withdraw : Euro.c -> Euro.c
  end

Есть решение лучше:

#class account_with_deposit x =
   object (self)
     inherit account_with_history 
     initializer self#deposit x
   end;;

class account_with_deposit :
  Euro.c ->
  object
    val mutable balance : Euro.c
    val mutable history : Euro.c operation list
    method balance : Euro.c
    method deposit : Euro.c -> unit
    method history : Euro.c operation list
    method private trace : Euro.c operation -> unit
    method withdraw : Euro.c -> Euro.c
  end

Оно безопаснее, так как вызов метода deposit автоаматически влечет за собой проверку значения и запись о событии в журнал. Проверим:

#let ccp = new account_with_deposit (euro 100.) in 
 let balance = ccp#withdraw (euro 50.) in
 ccp#history;;

- : Euro.c operation list = [Deposit <obj>; Retrieval <obj>]

Закрытие счета осуществляется следующей полиморфной функцией:

#let close c = c#withdraw (c#balance);;

val close : < balance : 'a; withdraw : 'a -> 'b; .. > -> 'b = <fun>

Разумеется, она рабоает для всех типов счетов.

Наконец, несколько версий счета собираются в модуль Account, абстрагированный от типа валюты:

#let today () = (01,01,2000) (* приблизительно *)
 module Account (M:MONEY) =
   struct
     type m = M.c
     let m = new M.c
     let zero = m 0. 
         
     class bank =
       object (self) 
         val mutable balance = zero
         method balance = balance
         val mutable history = []
         method private trace x = history <- x::history
         method deposit x =
           self#trace (Deposit x);
           if zero#leq x then balance <- balance # plus x
           else raise (Invalid_argument "deposit")
         method withdraw x =
           if x#leq balance then
             (balance <- balance # plus (neg x); self#trace (Retrieval x); x)
           else zero
         method history = List.rev history
       end
         
     class type client_view = 
     object
         method deposit : m -> unit
         method history : m operation list
         method withdraw : m -> m
         method balance : m
       end
           
     class virtual check_client x = 
       let y = if (m 100.)#leq x then x
       else raise (Failure "Insufficient initial deposit") in
       object (self) initializer self#deposit y end
         
     module Client (B : sig class bank : client_view end) =
       struct
         class account x : client_view =
           object
             inherit B.bank
             inherit check_client x
           end
             
         let discount x =
           let c = new account x in
           if today() < (1998,10,30) then c # deposit (m 100.); c
       end
   end;;

Таким образом, модули помогают группировать определения классов, которые в результате рассматриваются как единое целое. Подобный модуль предоставляется банком как для внешнего, так и для внутреннего использования. Он реализован как функтор, абстрагированный от конкретной валюты, поэтому один и тот же код подходит для работы со счетами, ведущимися в разных денежных единицах.

Класс bank является полной реализацией банковского счета (его можно встраивать). Он пригоден для дальнешего расширения, уточнения и т.д. Клиент же, напротив, увидит только client_view.

#module Euro_account = Account(Euro);;
 
 module Client = Euro_account.Client (Euro_account);;
 
 new Client.account (new Euro.c 100.);;

Клиенты не имеют прямого доступа ни к методу balance, ни к history. Единственный для них способ изменить состояние счета - это положить или снять деньги. Необходимо предоставить клиентам именно класс, а не просто возможность создавать счета (типа поощрительного счета discount), чтобы они могли персонализовать его. Например, клиент может расширить методы deposit и withdraw, чтобы вести собственную финансовую историю. С другой стороны, функция discount определена так, что ее персонализация невозможна.

Клиентская часть должна быть построена как функтор Client, тогда даже после специализации класса bank создание клиентских счетов останется возможным. Функтор в этом случае может остаться неизменным и даже в новом определении будет создавать клиентскую часть.

#module Investment_account (M : MONEY) = 
   struct
     type m = M.c
     module A = Account(M)
         
     class bank =
       object
         inherit A.bank as super
         method deposit x =
           if (new M.c 1000.)#leq x then
             print_string "Would you like to invest?";
           super#deposit x
       end
         
     module Client = A.Client
   end;;

Точно так же можно переопределить и функтор Client, дополнив его новыми возможностями, доступными клиенту.

#module Internet_account (M : MONEY) = 
   struct
     type m = M.c
     module A = Account(M)

     class bank =
       object
         inherit A.bank 
         method mail s = print_string s
       end
         
     class type client_view = 
       object
         method deposit : m -> unit
         method history : m operation list
         method withdraw : m -> m
         method balance : m
         method mail : string -> unit
       end
           
     module Client (B : sig class bank : client_view end) =
       struct
         class account x : client_view =
           object
             inherit B.bank
             inherit A.check_client x
           end
       end
   end;;

5.2 Простые модули как классы

Может возникнуть вопрос, возможно ли рассматривать как объекты примитивные типы, такие как целые числа или строки. Для строк или целых чисел в этом особого смысла обычно нет, но в некоторых ситуациях подобные вещи полезны. Пример тому - класс money. Ниже показано, как это делается для строк.

5 . 2.1 Строки

Наивное определение строки может быть таким:

#class ostring s =
   object
      method get n = String.get n
      method set n c = String.set n c
      method print = print_string s
      method copy = new ostring (String.copy s)
   end;;

class ostring :
  string ->
  object
    method copy : ostring
    method get : string -> int -> char
    method print : unit
    method set : string -> int -> char -> unit
  end

Однако метод copy возвращает объект класса string, а не текущего класса. Поэтому при дальнейшем расширении copy будет возвращать только объект родительского класса:

#class sub_string s =
   object
      inherit ostring s
      method sub start len = new sub_string (String.sub s  start len)
   end;;

class sub_string :
  string ->
  object
    method copy : ostring
    method get : string -> int -> char
    method print : unit
    method set : string -> int -> char -> unit
    method sub : int -> int -> sub_string
  end

Как мы видели в разделе 3.15, выходом может быть использование функционального обновления. Надо создать переменную экземпляра, хранящую значение s.

#class better_string s =
   object
      val repr = s
      method get n = String.get n
      method set n c = String.set n c
      method print = print_string repr
      method copy = {< repr = String.copy repr >}
      method sub start len = {< repr = String.sub s  start len >}
   end;;

class better_string :
  string ->
  object ('a)
    val repr : string
    method copy : 'a
    method get : string -> int -> char
    method print : unit
    method set : string -> int -> char -> unit
    method sub : int -> int -> 'a
  end

Как видно из сокращения, методы copy и sub теперь возвращают объекты того же типа, что и сам класс.

Еще одно затруднение проявляется в реализации метода concat. Чтобы объединить две строки, надо получить доступ извне к переменной экземпляра. Поэтому появляется метод repr, возвращающий s. Вот правильное определение строки:

#class ostring s =
   object (self : 'mytype)
      val repr = s
      method repr = repr
      method get n = String.get n
      method set n c = String.set n c
      method print = print_string repr
      method copy = {< repr = String.copy repr >}
      method sub start len = {< repr = String.sub s start len >}
      method concat (t : 'mytype) = {< repr = repr ^ t#repr >}
   end;;

class ostring :
  string ->
  object ('a)
    val repr : string
    method concat : 'a -> 'a
    method copy : 'a
    method get : string -> int -> char
    method print : unit
    method repr : string
    method set : string -> int -> char -> unit
    method sub : int -> int -> 'a
  end

Можно определить еще один конструктор класса, возвращающий неинициализированную строку заданнной длины:

#class cstring n = ostring (String.create n);;

class cstring : int -> ostring

Доступ к реализации строки, вероятно, безопасен. Однако, можно и скрыть реализацию, как это делалось для валюты в классе money в разделе 3.16.

5 . 2.2 Стеки

Для параметризованных типов данных иногда непонятно, стоит ли использовать модули или классы. Действительно, в некоторых ситуациях оба подхода дают примерно одинаковый результат. Стек, например, может быть реализован непосредственно как класс.

#exception Empty;;

exception Empty

#class ['a] stack =
   object 
     val mutable l = ([] : 'a list)
     method push x = l <- x::l
     method pop = match l with [] -> raise Empty | a::l' -> l <- l'; a
     method clear = l <- []
     method length = List.length l
   end;;

class ['a] stack :
  object
    val mutable l : 'a list
    method clear : unit
    method length : int
    method pop : 'a
    method push : 'a -> unit
  end

Однако написать метод для итерации по стеку гораздо сложнее. Метод fold будет иметь тип ('b -> 'a -> 'b) -> 'b -> 'b. 'a здесь является параметром стека. Параметр 'b относится не к классу 'a stack, а к параметру метода fold. Проще всего сделать 'b дополнительным параметром класса stack.

#class ['a, 'b] stack2 =
   object
     inherit ['a] stack
     method fold f (x : 'b) = List.fold_left f x l
   end;;

class ['a, 'b] stack2 :
  object
    val mutable l : 'a list
    method clear : unit
    method fold : ('b -> 'a -> 'b) -> 'b -> 'b
    method length : int
    method pop : 'a
    method push : 'a -> unit
  end

Но тогда метод fold данного объекта будет применим только к функциям, имеющим тот же тип:

#let s = new stack2;;

val s : ('_a, '_b) stack2 = <obj>

#s#fold (+) 0;;

- : int = 0

#s;;

- : (int, int) stack2 = <obj>

Лучше использовать полиморфные методы, появшиеся в Objective Caml с версии 3.05. Они позволяют считать переменную 'b универсально квантифицируемой, так что метод fold получает тип Forall 'b. ('b -> 'a -> 'b) -> 'b -> 'b. В данном случае требуется явное объявление типа метода, поскольку механизм проверки типов не может сам определить полиморфный тип.

#class ['a] stack3 =
   object
     inherit ['a] stack
     method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b
                 = fun f x -> List.fold_left f x l
   end;;

class ['a] stack3 :
  object
    val mutable l : 'a list
    method clear : unit
    method fold : ('b -> 'a -> 'b) -> 'b -> 'b
    method length : int
    method pop : 'a
    method push : 'a -> unit
  end

5 . 2.3 Хэш-таблицы

Упрощенная версия объектно-ориентированной хэш-таблицы может иметь следующий тип класса:

#class type ['a, 'b] hash_table =
   object 
     method find : 'a -> 'b
     method add : 'a -> 'b -> unit
   end;;

class type ['a, 'b] hash_table =
  object method add : 'a -> 'b -> unit method find : 'a -> 'b end

Для небольших хэш-таблиц подходит реализация с использованием ассоциативного списка:

#class ['a, 'b] small_hashtbl : ['a, 'b] hash_table =
   object
     val mutable table = []
     method find key = List.assoc key table
     method add key valeur = table <- (key, valeur) :: table
   end;;

class ['a, 'b] small_hashtbl : ['a, 'b] hash_table

Лучшую масштабируемость обеспечивает реализация основанная на настоящих хэш-таблицах, элементы которых... также являются маленькими хэш-таблицами.

#class ['a, 'b] hashtbl size : ['a, 'b] hash_table =
   object (self)
     val table = Array.init size (fun i -> new small_hashtbl) 
     method private hash key =
       (Hashtbl.hash key) mod (Array.length table)
     method find key = table.(self#hash key) # find key
     method add key = table.(self#hash key) # add key
   end;;

class ['a, 'b] hashtbl : int -> ['a, 'b] hash_table

5 . 2.4 Наборы

Реализация наборов связана с очередной трудностью. Дело в том, что метод union должен иметь доступ к внутреннему представлению другого объекта того же класса.

Это второе появление дружественных функций (первое было в разделе 3.16). Действительно, Set тоже реализуется как модуль без объектов.

В объектно-ориентированной версии наборов требуется только добавить метод tag, возвращающий представление набора. Поскольку набор параметризуется типом элементов, этот метод имеет параметрический тип 'a tag, конкретный в определении модуля, но абстрактный в сигнатуре. Таким образом, два объекта с методом tag одного типа гарантировано будут иметь общее представление извне.

#module type SET =
   sig
     type 'a tag
     class ['a] c :
       object ('b)
         method is_empty : bool
         method mem : 'a -> bool
         method add : 'a -> 'b
         method union : 'b -> 'b
         method iter : ('a -> unit) -> unit
         method tag : 'a tag
       end
   end;;
 
 module Set : SET =
   struct
     let rec merge l1 l2 =
       match l1 with
         [] -> l2
       | h1 :: t1 ->
           match l2 with
             [] -> l1
           | h2 :: t2 ->
               if h1 < h2 then h1 :: merge t1 l2
               else if h1 > h2 then h2 :: merge l1 t2
               else merge t1 l2
     type 'a tag = 'a list
     class ['a] c =
       object (_ : 'b)
         val repr = ([] : 'a list)
         method is_empty = (repr = [])
         method mem x = List.exists ((=) x) repr
         method add x = {< repr = merge [x] repr >}
         method union (s : 'b) = {< repr = merge repr s#tag >}
         method iter (f : 'a -> unit) = List.iter f repr
         method tag = repr
       end
   end;;

5.3 Шаблон субъект/наблюдатель

Следующий пример, известный как шаблон субъект/наблюдатель, часто связывается в литературе со сложной проблемой наследования классов, объединенных внутренними отношениями. Как правило, определяются два класса, рекурсивно взаимодействующие друг с другом.

Класс observer включает характерный метод notify, принимающий два аргумента - субъект и событие, требующее действия.

#class virtual ['subject, 'event] observer =
   object
     method virtual notify : 'subject ->  'event -> unit
   end;;

class virtual ['a, 'b] observer :
  object method virtual notify : 'a -> 'b -> unit end

Класс subject записывает наблюдателей в переменную экземпляра и с помощью метода notify_observers рассылает всем им сообщения notify с событием e.

#class ['observer, 'event] subject =
   object (self)
     val mutable observers = ([]:'observer list)
     method add_observer obs = observers <- (obs :: observers)
     method notify_observers (e : 'event) = 
         List.iter (fun x -> x#notify self e) observers
   end;;

class ['a, 'b] subject :
  object ('c)
    constraint 'a = < notify : 'c -> 'b -> unit; .. >
    val mutable observers : 'a list
    method add_observer : 'a -> unit
    method notify_observers : 'b -> unit
  end

Обычно наиболее сложно определять классы по этому шаблону с помощью наследования. В OCaml подобные проблемы решаются естественным и очевидным способом, как показано ниже в примере с окнами.

#type event = Raise | Resize | Move;;

type event = Raise | Resize | Move

#let string_of_event = function
     Raise -> "Raise" | Resize -> "Resize" | Move -> "Move";;

val string_of_event : event -> string = <fun>

#let count = ref 0;;

val count : int ref = {contents = 0}

#class ['observer] window_subject =
   let id = count := succ !count; !count in
   object (self)
     inherit ['observer, event] subject
     val mutable position = 0
     method identity = id
     method move x = position <- position + x; self#notify_observers Move
     method draw = Printf.printf "{Position = %d}\n"  position;
   end;;

class ['a] window_subject :
  object ('b)
    constraint 'a = < notify : 'b -> event -> unit; .. >
    val mutable observers : 'a list
    val mutable position : int
    method add_observer : 'a -> unit
    method draw : unit
    method identity : int
    method move : int -> unit
    method notify_observers : event -> unit
  end

#class ['subject] window_observer =
   object
     inherit ['subject, event] observer
     method notify s e = s#draw
   end;;

class ['a] window_observer :
  object
    constraint 'a = < draw : unit; .. >
    method notify : 'a -> event -> unit
  end

Неудивительно, что тип window рекурсивен.

#let window = new window_subject;;

val window : < notify : 'a -> event -> unit; _.. > window_subject as 'a =
  <obj>

Однако классы window_subject и window_observer не рекурсивны взаимно:

#let window_observer = new window_observer;;

val window_observer : < draw : unit; _.. > window_observer = <obj>

#window#add_observer window_observer;;

- : unit = ()

#window#move 1;;

{Position = 1}
- : unit = ()

Классы window_subject и window_observer могут быть расширены через наследование. Например, subject может получить новые функции, а функции наблюдателя могут быть переопределены:

#class ['observer] richer_window_subject =
   object (self)
     inherit ['observer] window_subject
     val mutable size = 1
     method resize x = size <- size + x; self#notify_observers Resize
     val mutable top = false
     method raise = top <- true; self#notify_observers Raise
     method draw = Printf.printf "{Position = %d; Size = %d}\n"  position size;
   end;;

class ['a] richer_window_subject :
  object ('b)
    constraint 'a = < notify : 'b -> event -> unit; .. >
    val mutable observers : 'a list
    val mutable position : int
    val mutable size : int
    val mutable top : bool
    method add_observer : 'a -> unit
    method draw : unit
    method identity : int
    method move : int -> unit
    method notify_observers : event -> unit
    method raise : unit
    method resize : int -> unit
  end

#class ['subject] richer_window_observer =
   object 
     inherit ['subject] window_observer as super
     method notify s e = if e <> Raise then s#raise; super#notify s e
   end;;

class ['a] richer_window_observer :
  object
    constraint 'a = < draw : unit; raise : unit; .. >
    method notify : 'a -> event -> unit
  end

Можно даже создать новый тип наблюдателя:

#class ['subject] trace_observer = 
   object 
     inherit ['subject, event] observer
     method notify s e =
       Printf.printf
         "<Window %d <== %s>\n" s#identity (string_of_event e)
   end;;

class ['a] trace_observer :
  object
    constraint 'a = < identity : int; .. >
    method notify : 'a -> event -> unit
  end

и привязать несколько наблюдателей к одному субъекту:

#let window = new richer_window_subject;;

val window :
  < notify : 'a -> event -> unit; _.. > richer_window_subject as 'a = <obj>

#window#add_observer (new richer_window_observer);;

- : unit = ()

#window#add_observer (new trace_observer);;

- : unit = ()

#window#move 1; window#resize 2;;

<Window 2 <== Move>
<Window 2 <== Raise>
{Position = 1; Size = 1}
{Position = 1; Size = 1}
<Window 2 <== Resize>
<Window 2 <== Raise>
{Position = 1; Size = 3}
{Position = 1; Size = 3}
- : unit = ()