Commits

Anonymous committed 4556f0d

concepts' bugfix

Comments (0)

Files changed (1)

  =
   struct
 
-    class map_ro ['k, 'v] =
-      object (self)
-
-        method get_exn (k : 'k) : 'v =
-          match self#get_opt k with
-          [ None -> raise Not_found
-          | Some v -> v
-          ]
-        ;
-
-        method get_opt (k : 'k) : option 'v =
-          try Some (self#get_exn k)
-          with [ Not_found -> None ]
-        ;
-
-        method mem k =
-          try (ignore (self#get_exn k); True) with [Not_found -> False]
-        ;
-
+    class type map_ro ['k, 'v] =
+      object
+        method get_exn : 'k -> 'v;
+        method get_opt : 'k -> option 'v;
+        method mem : 'k -> bool;
       end
     ;
 
  =
   struct
 
+    class type map_rw ['k, 'v] =
+      object
+        inherit T.map_ro ['k, 'v];
 (*
-    class virtual map_w ['k, 'v] =
-      object (_self)
-
-        method virtual add : 'k -> 'v -> map_w 'k 'v;
-
-        method virtual remove : 'k -> map_w 'k 'v;
-
-        method virtual replace : 'k -> 'v -> map_w 'k 'v;
-
-      end
-    ;
+       get_exn : 'k -> 'v
+      ; get_opt : 'k -> option 'v
+      ; mem : 'k -> bool
 *)
 
-    class virtual map_rw ['k, 'v] =
-      object (self)
-
-        inherit T.map_ro ['k, 'v];
-
-        method virtual add : 'k -> 'v -> map_rw 'k 'v;
-
-        method virtual remove : 'k -> map_rw 'k 'v;
-
-        method replace (k : 'k) (v : 'v) =
-          (if self#mem k then self#remove k else (self :> map_rw 'k 'v))
-          # add k v
-        ;
-
-      end
-    ;
-
-    class type t_map_rw ['k, 'v] =
-      object
-        method get_exn : 'k -> 'v;
-        method get_opt : 'k -> option 'v;
-        method mem : 'k -> bool;
-
         method add : 'k -> 'v -> map_rw 'k 'v;
         method remove : 'k -> map_rw 'k 'v;
         method replace : 'k -> 'v -> map_rw 'k 'v;
   end
 ;
 
+
 (* types of imperative/mutable structures *)
 
 module Timp
  =
   struct
 
-    class virtual map_rw ['k, 'v] =
-      object (self)
-
-        inherit T.map_ro ['k, 'v];
-
-        method virtual add : 'k -> 'v -> unit;
-
-        method virtual remove : 'k -> unit;
-
-        method replace (k : 'k) (v : 'v) =
-          ( self#remove k
-          ; self#add k v
-          )
-        ;
-
-      end
-    ;
-
-    class type t_map_rw ['k, 'v] =
+    class type map_rw ['k, 'v] =
       object
         method get_exn : 'k -> 'v;
         method get_opt : 'k -> option 'v;
         method mem : 'k -> bool;
-
         method add : 'k -> 'v -> unit;
         method remove : 'k -> unit;
         method replace : 'k -> 'v -> unit;
   end
 ;
 
+(* implementations *)
 
-(* functional/immutable structures (implementations) *)
-
-module Sfun
+module Cd_list
  =
   struct
 
         List.rev_append rev_heads tail
     ;
 
+    value get_exn ~keq cur k =
+      let rec loop lst =
+        match lst with
+        [ [] -> raise Not_found
+        | [(hk, hv) :: tl] ->
+            if keq k hk
+            then hv
+            else loop tl
+        ]
+      in
+        loop cur
+    ;
 
-    class map_ro_assoc ['k, 'v] ~keq cur
-    =
-      object (_self : #T.map_ro 'k 'v)
+    value get_opt ~keq cur k =
+      try Some (get_exn ~keq cur k)
+      with [Not_found -> None]
+    ;
 
-        inherit T.map_ro ['k, 'v];
-
-        method! get_exn k =
-          loop cur
-          where rec loop lst =
-            match lst with
-            [ [] -> raise Not_found
-            | [(hk, hv) :: tl] ->
-                if keq k hk
-                then hv
-                else loop tl
-            ]
-        ;
-
-        method! mem k =
+    value mem ~keq cur k =
           let rec loop lst =
             match lst with
             [ [] -> False
             ]
           in
             loop cur
-        ;
-
-      end
     ;
 
-    value map_rw_assoc_add k v cur =
+    value map_rw_assoc_add cur k v =
       [(k, v) :: cur]
     ;
 
-    value map_rw_assoc_remove ~keq k cur =
+    value map_rw_assoc_remove ~keq cur k =
       match list_assoc_index_opt ~keq cur k with
       [ None -> cur
       | Some i ->
       ]
     ;
 
-    class map_rw_assoc ['k, 'v] ~keq cur
+  end
+;
+
+
+(* functional/immutable structures (classes/objects, what is exported) *)
+
+module Sfun
+ =
+  struct
+
+    class map_ro_assoc ['k, 'v] ~keq cur : T.map_ro ['k, 'v]
     =
-      object (self : #Tfun.map_rw 'k 'v)
+      object (_self)
+        method get_exn k = Cd_list.get_exn ~keq cur k;
+        method get_opt k = Cd_list.get_opt ~keq cur k;
+        method mem k = Cd_list.mem ~keq cur k;
+      end
+    ;
 
+    class map_rw_assoc ['k, 'v] ~keq cur : Tfun.map_rw ['k, 'v]
+    =
+      object (self)
         inherit map_ro_assoc ['k, 'v] ~keq cur;
-
-        method add k v = new map_rw_assoc ~keq (map_rw_assoc_add k v cur);
-
+        method add k v = new map_rw_assoc ~keq
+          (Cd_list.map_rw_assoc_add cur k v);
         method remove k =
-          let new_cur = map_rw_assoc_remove ~keq k cur in
+          let new_cur = Cd_list.map_rw_assoc_remove ~keq cur k in
           if cur == new_cur
           then (self :> map_rw_assoc 'k 'v)
           else new map_rw_assoc ~keq new_cur
         ;
-
         method replace k v =
-          let removed = map_rw_assoc_remove ~keq k cur in
-          let added = map_rw_assoc_add k v removed in
+          let removed = Cd_list.map_rw_assoc_remove ~keq cur k in
+          let added = Cd_list.map_rw_assoc_add removed k v in
           new map_rw_assoc ~keq added
         ;
-
       end
     ;
 
 
     module Tree
-      (T : Map.OrderedType)
+      (Key : Map.OrderedType)
      :
       sig
-        class map_rw_tree ['v] : Tfun.t_map_rw [T.t, 'v];
+        class map_ro_tree ['v] : T.map_ro [Key.t, 'v];
+        class map_rw_tree ['v] : Tfun.map_rw [Key.t, 'v];
       end
      =
       struct
 
-        module M = Map.Make(T);
+        module M = Map.Make(Key);
 
-        class map_rw_tree_cur ['v] cur
+        module Cd_tree
+         =
+           struct
+             value get_exn cur k = M.find k cur;
+             value get_opt cur k =
+               try Some (get_exn cur k)
+               with [Not_found -> None];
+             value mem cur k = M.mem k cur;
+             value add cur k v = M.add k v cur;
+             value remove cur k = M.remove k cur;
+           end
+        ;
+
+
+        class map_ro_tree_cur ['v] cur : T.map_ro [Key.t, 'v]
         =
-          object (_self : #Tfun.map_rw 'k 'v)
-            inherit Tfun.map_rw ['k, 'v];
-            method! get_exn k = M.find k cur;
-            method add k v =
-              new map_rw_tree_cur (M.add k v cur)
+          object (_self)
+            method get_exn k = Cd_tree.get_exn cur k;
+            method get_opt k = Cd_tree.get_opt cur k;
+            method mem k = Cd_tree.mem cur k;
+          end
+        ;
+
+        class map_rw_tree_cur ['v] cur : Tfun.map_rw [Key.t, 'v]
+        =
+          object (_self)
+            inherit map_ro_tree_cur ['v] cur;
+            method add k v = new map_rw_tree_cur (Cd_tree.add cur k v);
+            method remove k =
+              new map_rw_tree_cur (Cd_tree.remove cur k)
             ;
-            method remove k =
-              new map_rw_tree_cur (M.remove k cur)
+            method replace k v =
+              let removed = Cd_tree.remove cur k in
+              let added = Cd_tree.add removed k v in
+              new map_rw_tree_cur added
             ;
           end
         ;
 
+        class map_ro_tree ['v]
+        =
+          map_ro_tree_cur ['v] M.empty
+        ;
+
         class map_rw_tree ['v]
         =
           map_rw_tree_cur ['v] M.empty
 ;
 
 
-(* imperative/mutable structures (implementations) *)
+
+(* imperative/mutable structures (classes/objects, what is exported) *)
 
 module Simp
  =
   struct
 
     class map_rw_of_Sfun ['k, 'v] (fu : Tfun.map_rw 'k 'v)
+    : Timp.map_rw ['k, 'v]
     =
-      object (_self : #Timp.map_rw 'k 'v)
-
-        inherit Timp.map_rw ['k, 'v];
+      object (_self)
 
         value mutable cur = fu;
 
+        method get_exn k = cur#get_exn k;
+        method get_opt k = cur#get_opt k;
+        method mem k = cur#mem k;
+
         method add k v = cur := cur#add k v;
 
         method remove k =
           else cur := new_cur
         ;
 
-        method! replace (k : 'k) (v : 'v) =
-          let new_cur = cur#replace k v in
-          if new_cur == cur
-          then ()
-          else cur := new_cur
+        method replace (k : 'k) (v : 'v) =
+          cur := cur#replace k v
         ;
 
       end
       (T : Map.OrderedType)
      :
       sig
-        class map_rw_tree ['v] : Timp.t_map_rw [T.t, 'v];
+        class map_rw_tree ['v] : Timp.map_rw [T.t, 'v];
       end
      =
       struct