1. Dmitry Grebeniuk
  2. cadastr

Commits

Dmitry Grebeniuk  committed 28f02ae

merge from amall, some fixes, Strings.* now provide TFULL signature

  • Participants
  • Parent commits 27b77bc
  • Branches default

Comments (0)

Files changed (2)

File src/cd_List.ml

View file
 
     include List;
 
+    type t 'a = list 'a;
+
+    open Cd_Ops;
+
     value rec for_ lst f =
       match lst with
       [ [] -> ()
       ]
     ;
 
-
-    type t 'a = list 'a;
-
-    open Cd_Ops;
-
     value reduce : Monoid.t 'a -> t 'a -> 'a
     = fun mon lst ->
         fold_left mon#plus mon#zero lst
     ;
 
-    value map_reduce : ('a -> 'b) -> Monoid.t 'b -> t 'a -> 'b
+    value map_reduce_left : ('a -> 'b) -> Monoid.t 'b -> t 'a -> 'b
     = fun f mon lst ->
         let plus = mon#plus in
         fold_left
           lst
     ;
 
+    value map_reduce = map_reduce_left;  (* как-нибудь удолить *)
 
+    value reduce_left mapfunc reducefunc lst =
+      match lst with
+      [ [] -> invalid_arg "Am_List.reduce_left: empty input list"
+      | [h :: t] ->
+          inner ~acc:(mapfunc h) t
+          where rec inner ~acc lst =
+            match lst with
+            [ [] -> acc
+            | [h :: t] ->
+                inner t ~acc:(reducefunc acc (mapfunc h))
+            ]
+      ]
+    ;
 
 
     value remove_nth_fast i lst =
     ;
 
 
+    value find_opt pred lst =
+      try
+        Some (List.find pred lst)
+      with
+      [ Not_found -> None ]
+    ;
+
+    value rec drop_while pred lst =
+      match lst with
+      [ [] -> []
+      | [ hd :: tl ] ->
+          if pred hd
+          then drop_while pred tl
+          else lst
+      ]
+    ;
+
+    value last_exn lst =
+      match lst with
+      [ [] -> failwith "Cd_List.last_exn"
+      | [h :: t] ->
+          inner h t
+          where rec inner prev lst =
+            match lst with
+            [ [] -> prev
+            | [h :: t] -> inner h t
+            ]
+      ]
+    ;
+
+    value last_opt lst =
+      try Some (last_exn lst)
+      with [ Failure "Cd_List.last_exn" -> None ]
+    ;
+
+
+    value concat_with between lol =
+      match lol with
+      [ [] -> []
+      | [first :: rest] ->
+          inner (List.rev first) rest
+          where rec inner rev_acc lol =
+            match lol with
+            [ [] -> List.rev rev_acc
+            | [h :: t] ->
+                inner
+                  (List.rev_append
+                     h
+                     (List.rev_append between rev_acc)
+                  )
+                  t
+            ]
+      ]
+    ;
+
+
+    (* returns: ([pre], [this], [rest]) or ([pre], [], []) *)
+
+    value split_by_first pred lst =
+      inner [] lst
+      where rec inner rev_acc lst =
+        match lst with
+        [ [] -> (List.rev rev_acc, [], [])
+        | [h :: t] ->
+            if pred h
+            then (List.rev rev_acc, [h], t)
+            else inner [h :: rev_acc] t
+        ]
+    ;
+
+
+    (* splits a list [lst] to list of lists by delimiting
+       element that matches [pred] *)
+
+    value split_by pred lst =
+      loop [] lst
+      where rec loop rev_acc lst =
+        if lst = []
+        then List.rev rev_acc
+        else
+          let (pre, _delim, rest) = split_by_first pred lst in
+          loop [pre :: rev_acc] rest
+    ;
+
+
+    value map_filter func lst =
+      inner [] lst
+      where rec inner rev_acc lst =
+        match lst with
+        [ [] -> List.rev rev_acc
+        | [h :: t] ->
+            match func h with
+            [ None -> inner rev_acc t
+            | Some x -> inner [x :: rev_acc] t
+            ]
+        ]
+    ;
+
+    value hd_opt = fun
+      [ [] -> None
+      | [x :: _] -> Some x
+      ]
+    ;
+
+    value hd_exn = List.hd;
+
+
+    value get_single lst =
+      let fail reason = failwith ("Cd_List.get_single: " ^ reason) in
+      match lst with
+      [ [] -> fail "empty list"
+      | [x :: []] -> x
+      | [_ :: [_ :: _]] -> fail "more than one element"
+      ]
+    ;
+
+    value get_pair lst =
+      let fail reason = failwith
+        ("Cd_List.get_pair: expected list of two elements, got " ^ reason) in
+      match lst with
+      [ [] -> fail "empty list"
+      | [_ ::[]] -> fail "list of one element"
+      | [x :: [y :: []]] -> (x, y)
+      | _ -> fail "list of more than two elements"
+      ]
+    ;
+
+
+
+
+
+    (* ** в Cd_List реализовал похожее, потом надо будет слить.
+
+    value assoc_count ?(cmp=Pervasives.compare) k t =
+      inner 0 t
+      where rec inner n t =
+        match t with
+        [ [] -> n
+        | [(hk,_hv)::t] ->
+            inner (if cmp k hk = 0 then (n+1) else n) t
+        ]
+    ;
+
+    value assoc_opt ?(cmp=Pervasives.compare) k t =
+      inner t
+      where rec inner t =
+        match t with
+        [ [] -> None
+        | [(hk, hv) :: t] ->
+            if cmp k hk = 0
+            then Some hv
+            else inner t
+        ]
+    ;
+
+
+    (* non tail-rec, GC-wise (does not recreate cons cells without need) *)
+
+    value rec assoc_remove ?(cmp=Pervasives.compare) k t =
+      let rec inner left t =
+        if left = 0
+        then t
+        else loop left t
+      and loop left t =
+        match t with
+        [ [] -> assert False
+        | [((hk,_hv) as h) :: t] ->
+            if cmp k hk = 0
+            then inner (left - 1) t
+            else [h :: loop left t]
+        ]
+      in
+        inner (assoc_count ~cmp k t) t
+    ;
+
+
+    value rec assoc_replace ?(cmp=Pervasives.compare) k v t =
+      [(k, v) :: assoc_remove ~cmp k t]
+    ;
+
+    ** *)
+
+
+
     module Assoc
      =
       struct
           else remove_all ~keq k r
         ;*)
 
-(* doesn't work!  (works assymetrically, longest lists' items absent
-   in shortest list are not processed; I leave the code here in case
-   when such behaviour will be needed later.)
-
+        (* doesn't work!  (works assymetrically, longest lists' items absent
+           in shortest list are not processed; I leave the code here in case
+           when such behaviour will be needed later.)
 
         value rec   assym_   merge_rwm2 ~keq ~f ~lshort ~llong ~acc =
           match lshort with
           merge_rwm2 ~keq ~lshort ~llong ~acc:[]
             ~f:(if l1 == lshort then f else fun x y z -> f x z y)
         ;
-*)
+        *)
 
 
         value to_arrays

File src/cd_Strings.ml

View file
  =
   struct
 
-    value map_reduce_byteenc : (char -> 'a) -> Monoid.t 'a -> string -> 'a
-    = fun f mon str ->
-        let plus = mon#plus
-        and len = String.length str in
-        inner mon#zero 0
-        where rec inner acc i =
-          if i = len
-          then acc
-          else inner (plus acc (f str.[i])) (i + 1)
-    ;
+    open Cd_Typeinfo;
+    open Cdt;
 
     value monoid_concat_gen = new Monoid.t "" ( ^ );
 
 
     type perv_char = char;
 
-    module TCommon : Cdt.TFULL with type t = string
+    module type TFUNCS
+     =
+      sig
+        value cmp : string -> string -> cmp_res;
+        value eq : string -> string -> bool;
+        value hash : string -> int;
+        value show : string -> string;
+        value opt_cmp : string -> string -> cmp_res;
+        value opt_eq : string -> string -> bool;
+        value opt_hash : string -> int;
+        value opt_show : string -> string;
+      end
+    ;
+
+    module TFuncs
      =
       struct
-
-        type t = string;
-
         value cmp (x : string) (y : string) =
           match  Pervasives.compare x y  with
           [ 0 -> Cdt.EQ
       end
     ;
 
+    module TCommon : Cdt.TFULL with type t = string
+     =
+      struct
+
+        type t = string;
+
+        include TFuncs;
+
+      end
+    ;
+
+
+    module type ONEBYTE
+     =
+      sig
+
+        (* from amall { *)
+        value is_prefix : ~string:string -> ~prefix:string -> bool;
+        value chop_prefix : ~string:string -> ~prefix:string -> string;
+        value is_suffix : ~string:string -> ~suffix:string -> bool;
+        value chop_suffix : ~string:string -> ~suffix:string -> string;
+        value trim_count : (char -> bool) -> string -> (int * string * int);
+        value trim : (char -> bool) -> string -> string;
+        value split_by_first :
+          (char -> bool) -> string -> (string * string * string);
+        value split_exact : (char -> bool) -> string -> list string;
+        value split : (char -> bool) -> string -> list string;
+        value decode_hex_opt : char -> option int;
+        value urldecode : string -> string;
+        value concat_array : string -> array string -> string;
+        value explode : string -> list char;
+        value compare_nocase_latin1 : string -> string -> int;
+        (* } from amall *)
+
+        value of_bytes : Cd_Bytes.Bytes.t -> string;
+        value of_char : char -> string;
+        value length_bytes : string -> int;
+
+        value map_reduce : (char -> 'a) -> Monoid.t 'a -> string -> 'a;
+        value monoid_concat : Monoid.t string;
+
+        value append : string -> string -> string;
+
+        value eq_nocase_latin1 : string -> string -> bool;
+        value cmp_nocase_latin1 : string -> string -> cmp_res;
+        value hash_nocase_latin1 : string -> int;
+
+      end
+    ;
+
+
+    module Onebyte : ONEBYTE
+     =
+      struct
+
+        type char = perv_char;
+
+        (* from amall { *)
+
+        value is_prefix ~string ~prefix =
+          let str_len = String.length string
+          and pref_len = String.length prefix in
+          pref_len <= str_len
+          && String.sub string 0 pref_len = prefix
+        ;
+
+        value chop_prefix ~string ~prefix =
+          let pref_len = String.length prefix in
+          if is_prefix ~string ~prefix
+          then String.sub string pref_len (String.length string - pref_len)
+          else string
+        ;
+
+        value is_suffix ~string ~suffix =
+          let str_len = String.length string
+          and suf_len = String.length suffix in
+          suf_len <= str_len &&
+          String.sub string (str_len - suf_len) suf_len = suffix
+        ;
+
+        value chop_suffix ~string ~suffix =
+          let suf_len = String.length suffix in
+          if is_suffix ~string ~suffix
+          then String.sub string 0 (String.length string - suf_len)
+          else string
+        ;
+
+        value trim_count pred s =
+          let len = String.length s in
+          let first_skipping =
+            inner 0
+            where rec inner i =
+              if i = len || not (pred s.[i])
+              then i
+              else inner (i + 1)
+          in
+            if first_skipping = len
+            then (len, "", 0)
+            else
+              let last_leaving =
+                inner (len - 1)
+                where rec inner i =
+                  let () = assert (i >= first_skipping) in
+                  if pred s.[i]
+                  then inner (i - 1)
+                  else i
+              in
+                let new_len = last_leaving - first_skipping + 1 in
+                ( first_skipping
+                , if new_len = len
+                  then s
+                  else String.sub s first_skipping new_len
+                , len - last_leaving - 1
+                )
+        ;
+
+        value trim pred s =
+          let (_firsts, res, _lasts) = trim_count pred s in
+          res
+        ;
+
+        value split_by_first pred s =
+          let len = String.length s in
+          let i =
+            inner 0
+            where rec inner i =
+              if i = len || pred s.[i]
+              then i
+              else inner (i + 1)
+          in
+            if i = len
+            then (s, "", "")
+            else
+              ( String.sub s 0 i
+              , String.sub s i 1
+              , String.sub s (i + 1) (len - i - 1)
+              )
+        ;
+
+
+        (* [split_exact ((=) '.') ".asd..sdf." = ["";"asd";"";"sdf";""]] *)
+        value split_exact pred s =
+          let len = String.length s in
+
+          let rec rev_delimiters rev_acc i =  (* including -1 and len *)
+            if i = len
+            then [len :: rev_acc]
+            else
+            if pred s.[i]
+            then
+              rev_delimiters [i :: rev_acc] (i + 1)
+            else
+              rev_delimiters rev_acc (i + 1)
+          in
+          let rev_dels = rev_delimiters [-1] 0 in
+          let rec inner acc rev_dels =
+            match rev_dels with
+            [ [] -> assert False
+            | [ _ :: [] ] -> acc
+            | [next :: ([this :: _] as tl)] ->
+                inner
+                  [(String.sub s (this+1) (next - this - 1)) :: acc]
+                  tl
+            ]
+          in
+            inner [] rev_dels
+        ;
+
+
+        (* todo: more effective implementation. *)
+
+        value split pred s =
+          List.filter ((<>) "") (split_exact pred s)
+        ;
+
+
+        value decode_hex_opt ch =
+          let c = Char.code ch in
+          if ch >= '0' && ch <= '9'
+          then Some (c - (Char.code '0'))
+          else if ch >= 'A' && ch <= 'F'
+          then Some (c - (Char.code 'A') + 10)
+          else if ch >= 'a' && ch <= 'f'
+          then Some (c - (Char.code 'a') + 10)
+          else None
+        ;
+
+
+        value urldecode s =
+          let len = String.length s in
+          let buf = Buffer.create (len / 3) in
+          loop 0
+          where rec loop i =
+            if i = len
+            then Buffer.contents buf
+            else
+              let out ch adv =
+                (Buffer.add_char buf ch; loop (i + adv))
+              in
+              match s.[i] with
+              [ '+' -> out '\x20' 1
+              | '%' as c0 ->
+                  if i + 2 >= len
+                  then out c0 1
+                  else
+                    let c1 = s.[i + 1]
+                    and c2 = s.[i + 2] in
+                    match (decode_hex_opt c1, decode_hex_opt c2) with
+                    [ (Some d1, Some d2) ->
+                        out (Char.chr (16*d1 + d2)) 3
+                    | _ -> out c0 1
+                    ]
+              | c -> out c 1
+              ]
+        ;
+
+
+        (* todo: more effective implementation *)
+
+        value concat_array sep str_arr =
+          String.concat sep (Array.to_list str_arr)
+        ;
+
+
+        value explode str =
+          inner [] (String.length str - 1)
+          where rec inner acc i =
+            if i < 0
+            then acc
+            else inner [str.[i] :: acc] (i - 1)
+        ;
+
+
+        value compare_nocase_latin1 s1 s2 =
+          let len1 = String.length s1 in
+          let len2 = String.length s2 in
+          let bound = min len1 len2 in
+          loop 0
+          where rec loop i =
+            if i = bound
+            then
+              Pervasives.compare len1 len2
+            else
+              match Pervasives.compare
+                (Char.uppercase s1.[i]) (Char.uppercase s2.[i])
+              with
+              [ 0 -> loop (i + 1)
+              | r -> r
+              ]
+        ;
+
+        value eq a b =
+          let open String in
+          let len = length a in
+          if len <> length b
+          then False
+          else
+            loop 0
+            where rec loop i =
+              if i = len
+              then True
+              else
+                if (unsafe_get a i) = (unsafe_get b i)
+                then loop (i + 1)
+                else False
+        ;
+
+
+        (* } from amall *)
+
+
+        value cmp_nocase_latin1 s1 s2 =
+          match compare_nocase_latin1 s1 s2 with
+          [ 0 -> EQ
+          | x when x < 0 -> LT
+          | _ (* when _ > 0 *) -> GT
+          ]
+        ;
+
+        value eq_nocase_latin1 a b =
+          let open String in
+          let len = length a in
+          if len <> length b
+          then False
+          else
+            loop 0
+            where rec loop i =
+              if i = len
+              then True
+              else
+                if (Char.uppercase (unsafe_get a i))
+                 = (Char.uppercase (unsafe_get b i))
+                then loop (i + 1)
+                else False
+        ;
+
+        value hash_nocase_latin1 s =
+          TCommon.hash (String.uppercase s)
+        ;
+
+
+        value of_bytes = String.copy;
+
+        value of_char =
+          let open Cd_Ops in
+          let arr = Array.init 256 (Char.chr @> String.make 1) in
+          fun c ->
+            arr.(Char.code c)
+        ;
+
+        value length_bytes = String.length;
+
+        value map_reduce : (char -> 'a) -> Monoid.t 'a -> string -> 'a
+         = fun f mon str ->
+             let plus = mon#plus
+             and len = String.length str in
+             inner mon#zero 0
+             where rec inner acc i =
+               if i = len
+               then acc
+                else inner (plus acc (f str.[i])) (i + 1)
+        ;
+
+        value monoid_concat = monoid_concat_gen;
+
+        value append = perv_append;
+
+        include TCommon;
+
+      end
+    ;
+
+
+    value latin1_tstring_nocase = Typeinfo.tfull
+      ~cmp:Onebyte.cmp_nocase_latin1
+      ~eq:Onebyte.eq_nocase_latin1
+      ~hash:Onebyte.hash_nocase_latin1
+      ()
+    ;
+
     module Perv
      =
       struct
         module String = String;
 
-        value map_reduce = map_reduce_byteenc;
-
-        value monoid_concat = monoid_concat_gen;
-
-        value ( ^ ) = perv_append;
-
-        type char = perv_char;
+        include Onebyte;
 
       end
     ;
 
+
     module Latin1
      =
       struct
             value compare : t -> t -> int;
             external unsafe_get : t -> int -> char = "%string_unsafe_get";
 
-            value of_bytes : Cd_Bytes.Bytes.t -> t;
-            value of_char : char -> t;
-            value length_bytes : t -> int;
-
-            value map_reduce : (char -> 'a) -> Monoid.t 'a -> string -> 'a;
-            value monoid_concat : Monoid.t string;
-
-            value append : t -> t -> t;
+            include ONEBYTE;
+            include TFUNCS;
 
           end
          =
 
             type char = Cd_Chars.Chars.Latin1.Char.t;
 
-            value of_bytes = copy;
-
-            open Cd_Ops;
-
-            value of_char =
-              let arr = Array.init 256 (Char.chr @> Perv.String.make 1) in
-              fun c ->
-                arr.(Char.code c)
-            ;
-
-            value map_reduce = map_reduce_byteenc;
-
-            value monoid_concat = monoid_concat_gen;
-
-            value append = perv_append;
-
-            value length_bytes = length;
+            include Onebyte;
+            include TFuncs;
 
           end
         ;
         value ( ^ ) = String.append;
         type char = String.char;
 
+        include TCommon;
+
       end  (* Latin1 *)
     ;
 
 
             value length_bytes : t -> int;
 
+            include TFUNCS;
+
           end
          =
           struct
 
             value length_bytes = S.length;
 
+            include TFuncs;
+
           end  (* Utf8.String *)
         ;