Commits

Dmitry Grebeniuk  committed 6885a06

Cadastr -> cadastr.ml

  • Participants
  • Parent commits d1466a1

Comments (0)

Files changed (2)

File amall_http_service.ml

 open Amall_types;
 open Printf;
 
-module Cadastr
- =
-  struct
-
-    value eq_of_cmp cmp = fun a b -> (0 = cmp a b)
-    ;
-
-    (* non-specific types *)
-
-    module T
-     =
-      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]
-            ;
-
-          end
-        ;
-
-      end
-    ;
-
-    (* types of functional/pure structures *)
-
-    module Tfun
-     =
-      struct
-
-(*
-        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
-        ;
-*)
-
-        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
-        ;
-
-      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] =
-          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
-        ;
-
-      end
-    ;
-
-
-    (* functional/immutable structures (implementations) *)
-
-    module Sfun
-     =
-      struct
-
-        value map_rw_assoc_stack_limit = 1000
-        ;
-
-        value list_assoc_index_opt ~keq lst k =
-          loop 0 lst
-          where rec loop i lst =
-            match lst with
-            [ [] -> None
-            | [(hk, _hv) :: tl] ->
-                if keq k hk
-                then Some i
-                else loop (i + 1) tl
-            ]
-        ;
-
-        value list_remove_nth_fast lst i =
-          if i < 0
-          then invalid_arg "list_remove_nth_fast: i<0"
-          else
-            inner lst i
-            where rec inner lst i =
-              match (i, lst) with
-              [ (_, []) -> invalid_arg "list_remove_nth_fast: i>=len"
-              | (0, [_h :: t]) -> t
-              | (i, [h :: t]) -> [h :: inner t (i - 1)]
-              ]
-        ;
-
-        value list_remove_nth_tailrec lst i =
-          let rec inner ~rev_acc lst i =
-            match (i, lst) with
-            [ (_, []) -> invalid_arg "list_remove_nth_tailrec: i>=len"
-            | (0, [_h :: t]) -> (rev_acc, t)
-            | (i, [h :: t]) -> inner ~rev_acc:[h :: rev_acc] t (i - 1)
-            ]
-          in
-          if i < 0
-          then invalid_arg "list_remove_nth_tailrec: i<0"
-          else
-            let (rev_heads, tail) = inner ~rev_acc:[] lst i in
-            List.rev_append rev_heads tail
-        ;
-
-
-        class map_ro_assoc ['k, 'v] ~keq cur
-        =
-          object (_self : #T.map_ro 'k 'v)
-
-            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 =
-              let rec loop lst =
-                match lst with
-                [ [] -> False
-                | [(hk, _hv) :: tl] ->
-                    if keq k hk then True else loop tl
-                ]
-              in
-                loop cur
-            ;
-
-          end
-        ;
-
-        value map_rw_assoc_add k v cur =
-          [(k, v) :: cur]
-        ;
-
-        value map_rw_assoc_remove ~keq k cur =
-          match list_assoc_index_opt ~keq cur k with
-          [ None -> cur
-          | Some i ->
-              let res_list =
-                if i < map_rw_assoc_stack_limit
-                then list_remove_nth_fast cur i
-                else list_remove_nth_tailrec cur i
-              in
-                res_list
-          ]
-        ;
-
-        class map_rw_assoc ['k, 'v] ~keq cur
-        =
-          object (self : #Tfun.map_rw 'k 'v)
-
-            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 remove k =
-              let new_cur = map_rw_assoc_remove ~keq k cur 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
-              new map_rw_assoc ~keq added
-            ;
-
-          end
-        ;
-
-
-        module Tree
-          (T : Map.OrderedType)
-         :
-          sig
-            class map_rw_tree ['v] : Tfun.t_map_rw [T.t, 'v];
-          end
-         =
-          struct
-
-            module M = Map.Make(T);
-
-            class map_rw_tree_cur ['v] cur
-            =
-              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)
-                ;
-                method remove k =
-                  new map_rw_tree_cur (M.remove k cur)
-                ;
-              end
-            ;
-
-            class map_rw_tree ['v]
-            =
-              map_rw_tree_cur ['v] M.empty
-            ;
-
-          end
-        ;
-
-      end
-    ;
-
-
-    (* imperative/mutable structures (implementations) *)
-
-    module Simp
-     =
-      struct
-
-        class map_rw_of_Sfun ['k, 'v] (fu : Tfun.map_rw 'k 'v)
-        =
-          object (_self : #Timp.map_rw 'k 'v)
-
-            inherit Timp.map_rw ['k, 'v];
-
-            value mutable cur = fu;
-
-            method add k v = cur := cur#add k v;
-
-            method remove k =
-              let new_cur = cur#remove k in
-              if new_cur == cur
-              then ()
-              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
-            ;
-
-          end
-        ;
-
-        class map_rw_assoc ['k, 'v] ~keq
-        =
-          map_rw_of_Sfun ['k, 'v] (new Sfun.map_rw_assoc ~keq [])
-        ;
-
-
-        module Tree
-          (T : Map.OrderedType)
-         :
-          sig
-            class map_rw_tree ['v] : Timp.t_map_rw [T.t, 'v];
-          end
-         =
-          struct
-
-            module F = Sfun.Tree(T);
-
-            class map_rw_tree ['v]
-            =
-              map_rw_of_Sfun [T.t, 'v] (new F.map_rw_tree)
-            ;
-
-          end
-        ;
-
-
-      end
-    ;
-
- end
-;
-
-
 open Cadastr
 ;
 
+value eq_of_cmp cmp = fun a b -> (0 = cmp a b)
+;
+
+(* non-specific types *)
+
+module T
+ =
+  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]
+        ;
+
+      end
+    ;
+
+  end
+;
+
+(* types of functional/pure structures *)
+
+module Tfun
+ =
+  struct
+
+(*
+    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
+    ;
+*)
+
+    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
+    ;
+
+  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] =
+      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
+    ;
+
+  end
+;
+
+
+(* functional/immutable structures (implementations) *)
+
+module Sfun
+ =
+  struct
+
+    value map_rw_assoc_stack_limit = 1000
+    ;
+
+    value list_assoc_index_opt ~keq lst k =
+      loop 0 lst
+      where rec loop i lst =
+        match lst with
+        [ [] -> None
+        | [(hk, _hv) :: tl] ->
+            if keq k hk
+            then Some i
+            else loop (i + 1) tl
+        ]
+    ;
+
+    value list_remove_nth_fast lst i =
+      if i < 0
+      then invalid_arg "list_remove_nth_fast: i<0"
+      else
+        inner lst i
+        where rec inner lst i =
+          match (i, lst) with
+          [ (_, []) -> invalid_arg "list_remove_nth_fast: i>=len"
+          | (0, [_h :: t]) -> t
+          | (i, [h :: t]) -> [h :: inner t (i - 1)]
+          ]
+    ;
+
+    value list_remove_nth_tailrec lst i =
+      let rec inner ~rev_acc lst i =
+        match (i, lst) with
+        [ (_, []) -> invalid_arg "list_remove_nth_tailrec: i>=len"
+        | (0, [_h :: t]) -> (rev_acc, t)
+        | (i, [h :: t]) -> inner ~rev_acc:[h :: rev_acc] t (i - 1)
+        ]
+      in
+      if i < 0
+      then invalid_arg "list_remove_nth_tailrec: i<0"
+      else
+        let (rev_heads, tail) = inner ~rev_acc:[] lst i in
+        List.rev_append rev_heads tail
+    ;
+
+
+    class map_ro_assoc ['k, 'v] ~keq cur
+    =
+      object (_self : #T.map_ro 'k 'v)
+
+        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 =
+          let rec loop lst =
+            match lst with
+            [ [] -> False
+            | [(hk, _hv) :: tl] ->
+                if keq k hk then True else loop tl
+            ]
+          in
+            loop cur
+        ;
+
+      end
+    ;
+
+    value map_rw_assoc_add k v cur =
+      [(k, v) :: cur]
+    ;
+
+    value map_rw_assoc_remove ~keq k cur =
+      match list_assoc_index_opt ~keq cur k with
+      [ None -> cur
+      | Some i ->
+          let res_list =
+            if i < map_rw_assoc_stack_limit
+            then list_remove_nth_fast cur i
+            else list_remove_nth_tailrec cur i
+          in
+            res_list
+      ]
+    ;
+
+    class map_rw_assoc ['k, 'v] ~keq cur
+    =
+      object (self : #Tfun.map_rw 'k 'v)
+
+        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 remove k =
+          let new_cur = map_rw_assoc_remove ~keq k cur 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
+          new map_rw_assoc ~keq added
+        ;
+
+      end
+    ;
+
+
+    module Tree
+      (T : Map.OrderedType)
+     :
+      sig
+        class map_rw_tree ['v] : Tfun.t_map_rw [T.t, 'v];
+      end
+     =
+      struct
+
+        module M = Map.Make(T);
+
+        class map_rw_tree_cur ['v] cur
+        =
+          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)
+            ;
+            method remove k =
+              new map_rw_tree_cur (M.remove k cur)
+            ;
+          end
+        ;
+
+        class map_rw_tree ['v]
+        =
+          map_rw_tree_cur ['v] M.empty
+        ;
+
+      end
+    ;
+
+  end
+;
+
+
+(* imperative/mutable structures (implementations) *)
+
+module Simp
+ =
+  struct
+
+    class map_rw_of_Sfun ['k, 'v] (fu : Tfun.map_rw 'k 'v)
+    =
+      object (_self : #Timp.map_rw 'k 'v)
+
+        inherit Timp.map_rw ['k, 'v];
+
+        value mutable cur = fu;
+
+        method add k v = cur := cur#add k v;
+
+        method remove k =
+          let new_cur = cur#remove k in
+          if new_cur == cur
+          then ()
+          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
+        ;
+
+      end
+    ;
+
+    class map_rw_assoc ['k, 'v] ~keq
+    =
+      map_rw_of_Sfun ['k, 'v] (new Sfun.map_rw_assoc ~keq [])
+    ;
+
+
+    module Tree
+      (T : Map.OrderedType)
+     :
+      sig
+        class map_rw_tree ['v] : Timp.t_map_rw [T.t, 'v];
+      end
+     =
+      struct
+
+        module F = Sfun.Tree(T);
+
+        class map_rw_tree ['v]
+        =
+          map_rw_of_Sfun [T.t, 'v] (new F.map_rw_tree)
+        ;
+
+      end
+    ;
+
+
+  end
+;