Anonymous avatar Anonymous committed 0db272c

moved from amdoing with its changes

Comments (0)

Files changed (11)

 "ops.ml" | "extStream.ml" : -camlp4r, camlp4o
 
 "iteratees.ml" : camlp4:no_quot
+
+<it_Lwt_IO.ml> | <tests_lwt.{byte,native}> : pkg_lwt, pkg_lwt.unix
+open Types
+;
+
+(* Lwt IO *)
+
+module It_Lwt_IO
+ :
+  sig
+    type m +'a = Lwt.t 'a;
+
+    value return : 'a -> m 'a;
+    value bind : ('a -> m 'b) -> m 'a -> m 'b;
+    value catch : (unit -> m 'a) -> (exn -> m 'a) -> m 'a;
+
+    value error : exn -> m 'a;
+
+    type output_channel = Lwt_io.output_channel;
+    value stdout : output_channel;
+    value write : output_channel -> string -> m unit;
+
+    type input_channel = Lwt_io.input_channel;
+    value open_in : string -> m input_channel;
+    value close_in : input_channel -> m unit;  (* Lwt_io.close inch *)
+    value read_into : input_channel -> string -> int -> int -> m int;
+       (* read_into ic buffer offset length *)
+
+    value runIO : m 'a -> res 'a;
+
+    value with_file_in_bin : string -> (input_channel -> m 'a) -> m 'a;
+    value with_file_out_bin : string -> (output_channel -> m 'a) -> m 'a;
+
+  end
+ =
+  struct
+    type m +'a = Lwt.t 'a;
+    value return = Lwt.return;
+    value bind f m = Lwt.bind m f;
+    value ( >>= ) = Lwt.bind;
+
+    value catch = Lwt.catch;
+
+(*
+    value try_bind m f handler =
+      catch (fun () -> m () >>= f) handler
+    ;
+*)
+
+
+    value wrap_exn place = fun e ->
+      Lwt.fail (EIO (e, place))
+    ;
+
+
+    value wrap1 place f = fun a ->
+      catch (fun () -> f a)
+      (wrap_exn place)
+    ;
+
+    value wrap2 place f = fun a b ->
+      catch (fun () -> f a b)
+      (wrap_exn place)
+    ;
+
+    value wrap4 place f = fun a b c d ->
+      catch (fun () -> f a b c d)
+      (wrap_exn place)
+    ;
+
+    value read_into = wrap4 "read_into" Lwt_io.read_into;
+
+    value error = Lwt.fail;
+
+    type output_channel = Lwt_io.output_channel;
+    value stdout = Lwt_io.stdout;
+    value write = wrap2 "write" Lwt_io.write;
+
+    type input_channel = Lwt_io.input_channel;
+
+    value open_in = wrap1 "open_in" (
+      fun fn ->
+        Lwt_io.open_file
+          ~mode:Lwt_io.input
+          ~flags:[Unix.O_RDONLY]
+         fn
+      )
+    ;
+
+    value close_in = wrap1 "close_in" Lwt_io.close;
+
+    value runIO x : res 'a =
+      try `Ok (Lwt_main.run x)
+      with [e -> `Error e]
+    ;
+
+    value with_file_in_bin filename func =
+      Lwt_io.with_file ~mode:Lwt_io.input filename func
+    ;
+
+    value with_file_out_bin filename func =
+      Lwt_io.with_file ~mode:Lwt_io.output filename func
+    ;
+
+  end
+;
   match it with
   [ IE_done a -> f a
   | IE_cont e k ->
-      let docase it_s =
-        match it_s with
-        [ (IE_done a, stream) ->
-            match f a with
-            [
-              IE_cont None m -> m stream
-            | (IE_cont (Some _) _ | IE_done _) as i ->
-                IO.return (i, stream)
-            ]
-        | (((IE_cont _) as i), s) -> IO.return (bindI f i, s)
-        ]
-      in
-        IE_cont e (fun s -> (k s >>% docase))
+      IE_cont e
+        (fun s ->
+           k s >>% fun
+           [ (IE_done a, stream) ->
+               match f a with
+               [ IE_cont None m -> m stream
+               | (IE_cont (Some _) _ | IE_done _) as i ->
+                   IO.return (i, stream)
+               ]
+           | (((IE_cont _) as i), s) -> IO.return (bindI f i, s)
+           ]
+        )
   ]
 ;
 
    "empty_stream" in ie_contM code is the reflection of fact (1).
 *)
 
-value ie_doneM x s = IO.return (IE_done x, s)
+value
+  ( ie_doneM : 'a -> stream 'el -> IO.m (iteratee 'el 'a  *  stream 'el) )
+  x s = IO.return (IE_done x, s)
 ;
 
 value ie_contM k = IO.return (IE_cont None k, empty_stream)
 ;
 
 
+module SC = Subarray_cat
+;
+
+module UTF8
+ :
+  sig
+    type uchar = private int;
+    value utf8_of_char : enumeratee char uchar 'a;
+  end
+ =
+  struct
+    type uchar = int;
+
+    exception Bad_utf8 of string
+    ;
+
+(*  without actual conversion:
+    value sc_ulen sc =
+      let len = SC.length sc in
+      (len, len, None)
+    ;
+    value sc_recode ~scfrom ~arrto ~uchars =
+      for i = 0 to uchars-1 do
+      ( arrto.(i) := Char.code & SC.get scfrom i
+      )
+      done
+    ;
+*)
+
+    value relaxed_utf8 = ref False  (* TODO: check it. *)
+    ;
+
+
+    value in_tail byte =
+      byte land 0b11_000_000 = 0b10_000_000
+
+    and bad_tail =
+      some & Bad_utf8 "tail != 0x80..0xBF"
+    ;
+
+
+    value decode_4bytes a b c d =
+      ((a land 0b00_000_111) lsl 18) lor
+      ((b land 0b00_111_111) lsl 12) lor
+      ((c land 0b00_111_111) lsl 6) lor
+      (d land 0b00_111_111)
+    ;
+
+
+    (* returns (count_of_chars, length_in_bytes, option error) *)
+    value (sc_ulen : SC.t char -> (int * int * option exn)) sc =
+      let sc_len = SC.length sc in
+      let get i = Char.code (SC.get sc i) in
+      let rec loop ~ch ~i =
+        if i = sc_len
+        then
+          (ch, i, None)
+        else
+          let byte = get i in
+          if byte < 0x80
+          then loop ~ch:(ch+1) ~i:(i+1)
+          else if byte <= 0xBF
+          then (ch, i, some & Bad_utf8 "head 0x80..0xBF")
+          else if byte <= 0xC1
+          then
+            (if relaxed_utf8.val
+             then skip_tail ~ch ~i ~sz:2
+             else (ch, i, some & Bad_utf8 "head 0xC0..0xC1 (overlong)")
+            )
+          else if byte < 0xE0
+          then skip_tail ~ch ~i ~sz:2
+          else if byte < 0xF0
+          then skip_tail ~ch ~i ~sz:3
+          else if byte <= 0xF4
+          then skip_tail ~ch ~i ~sz:4
+          else (ch, i, some & Bad_utf8 "head 0xF5..0xFF")
+      and skip_tail ~ch ~sz ~i =  (* check len, then check_tail *)
+        if i + sz > sc_len
+        then (ch, i, None)
+        else
+          (if sz = 4 && not relaxed_utf8.val
+           then check_tail4  (* check for codepoint too *)
+           else check_tail ~len:(sz-1)
+          ) ~i ~ch ~ifrom:(i+1)
+      and check_tail ~i ~ch ~ifrom ~len =  (* just check for 0b10xxxxxx *)
+        if len = 0
+        then loop ~ch:(ch+1) ~i:ifrom
+        else
+          let byte = get ifrom in
+          if in_tail byte
+          then check_tail ~i ~ch ~ifrom:(ifrom+1) ~len:(len-1)
+          else (ch, i, bad_tail)
+      and check_tail4 ~i ~ch ~ifrom =  (* 0b10xxxxxx and codepoint *)
+        let a = get i and b = get (i+1) and c = get (i+2) and d = get (i+3) in
+        if not (in_tail b && in_tail c && in_tail d)
+        then
+          (ch, i, bad_tail)
+        else
+          let codepoint = decode_4bytes a b c d in
+          if codepoint > 0x10FFFF
+          then (ch, i, some & Bad_utf8 "codepoint > 0x10FFFF")
+          else loop ~ch:(ch+1) ~i:(ifrom+4)
+      in
+        loop ~ch:0 ~i:0
+    ;
+
+
+    value sc_recode ~scfrom ~arrto ~uchars =
+      let get i = Char.code (SC.get scfrom i) in
+      let rec loop ~ifrom ~ito =
+        if ito = uchars
+        then ()
+        else
+          let a = get ifrom in
+          if a < 0x80
+          then put ~i:(ifrom+1) ~ito ~char:a
+          else if a < 0xC0
+          then assert False  (* sc_ulen checks this *)
+          else
+          let b = get (ifrom+1) in
+          if a < 0xE0
+          then
+            put ~i:(ifrom+2) ~ito ~char:(
+              ((a land     0b11_111) lsl 6) lor
+              ( b land 0b00_111_111)
+            )
+          else
+          let c = get (ifrom+2) in
+          if a < 0xF0
+          then
+            put ~i:(ifrom+3) ~ito ~char:(
+              ((a land      0b1_111) lsl 12) lor
+              ((b land 0b00_111_111) lsl  6) lor
+              ( c land 0b00_111_111)
+            )
+          else
+          let d = get (ifrom+3) in
+          put ~i:(ifrom+4) ~ito ~char:(decode_4bytes a b c d)
+
+      and put ~i ~ito ~char =
+        ( arrto.(ito) := char
+        ; loop ~ifrom:i ~ito:(ito+1)
+        )
+      in
+        loop ~ifrom:0 ~ito:0
+    ;
+
+
+    value ensure_size array_option_ref size =
+      let realloc () =
+        let r = Array.make size (-1) in
+        ( array_option_ref.val := Some r
+        ; r
+        )
+      in
+      match array_option_ref.val with
+      [ None -> realloc ()
+      | Some array ->
+          if Array.length array < size
+          then realloc ()
+          else
+            (* for debugging: *)
+            let () = Array.fill array 0 (Array.length array) (-2) in
+            array
+      ]
+    ;
+
+    value utf8_of_char uit =
+      let arr_ref = ref None in
+      let rec utf8_of_char ~acc uit =
+        match uit with
+        [ IE_cont None k -> ie_cont & fun s -> step ~acc ~k s
+        | IE_cont (Some _) _ | IE_done _ -> return uit
+        ]
+      and step ~acc ~k stream =
+        let err oe =
+          k (EOF oe) >>% fun (iv, _s) ->
+          IO.return (return iv, stream)
+        in
+        match (acc, stream) with
+        [ (`Error e, _) ->
+            (* TODO: test this branch. *)
+            (* let () = Printf.eprintf "utf8: (`Error, _)\n%!" in *)
+            err & Some e
+        | (_, EOF oe) ->
+            (* mprintf "utf8: (_, `EOF None=%b)\n%!" (oe=None) >>% fun () -> *)
+            err oe
+        | (`Acc acc, Chunk c) ->
+            let sc = SC.make [acc; c] in
+            let (ulen_chars, ulen_bytes, error_opt) = sc_ulen sc in
+            let res_arr = ensure_size arr_ref ulen_chars in
+            let () = sc_recode ~scfrom:sc ~arrto:res_arr ~uchars:ulen_chars in
+            k (Chunk (S.of_array_sub res_arr 0 ulen_chars)) >>% fun (iv, _) ->
+            let acc' = match error_opt with
+              [ None -> `Acc (SC.sub_copy_out sc ~ofs:ulen_bytes
+                              ~len:(SC.length sc - ulen_bytes)
+                             )
+              | Some e -> `Error e
+              ]
+            in
+            IO.return (utf8_of_char ~acc:acc' iv, empty_stream)
+        ]
+      in
+        utf8_of_char ~acc:(`Acc S.empty) uit
+    ;
+
+  end;  (* `UTF8' functor *)
+
+
+
+(* [break_copy ~cpred ~outch] reads input just like [break ~cpred],
+   but writes the input it has read into output channel [outch].
+*)
+
+value break_copy ~cpred ~outch : iteratee char unit =
+  IE_cont None step
+  where rec step s =
+    match s with
+    [ EOF _ as e -> ie_doneM () e
+    | Chunk c ->
+        if S.is_empty c
+        then ie_contM step
+        else
+          let (matches, tail) = S.break cpred c in
+          let matches_str = S.to_string matches in
+          ( IO.write outch matches_str >>% fun () ->
+            if S.is_empty tail
+            then ie_contM step
+            else ie_doneM () (Chunk tail)
+          )
+    ]
+;
+
+
+(* [break_limit ~pred ~limit] reads at most [limit] elements that
+   don't satisfy predicate [pred], and returns when it either
+   found element that satisfy [pred], or when [limit] elements were
+   read and no satisfying element was found, or when there were an
+   EOF or error found and neither any satisfying element was found
+   nor [limit] elements was read.
+   Returns: tuple [(status, subarray)], where
+     [status = [= `Found | `Hit_limit | `Hit_eof ]]
+     and [subarray] contains all the elements read.
+   If the stream has exactly [limit] elements and no elements
+   found, [`Hit_limit] is returned (limit has more priority
+   than stream's end).
+*)
+
+value break_limit ~pred ~limit
+: iteratee 'a ([= `Found | `Hit_limit | `Hit_eof] * S.t 'a) =
+  IE_cont None (step ~sc:(SC.make [S.empty]) ~left:limit)
+  where rec step ~sc ~left s =
+    let ret status sc s =
+      ie_doneM (status, SC.sub_copy_out sc) s
+    in
+    if left = 0
+    then
+      ret `Hit_limit sc s
+    else
+      match s with
+      [ EOF _ -> ret `Hit_eof sc s
+      | Chunk c ->
+          match S.break_limit ~limit:left pred c with
+          [ `Found (prefix, rest) ->
+              ret `Found (SC.append sc prefix) (Chunk rest)
+              (* not copying here, since [ret->sub_copy_out] will copy *)
+          | `Hit_limit ->
+              let (prefix, rest) = S.split_at left c in
+              step ~sc:(SC.append sc prefix) ~left:0 (Chunk rest)
+              (* not copying here, since [step->ret->sub_copy_out] will copy *)
+          | `Hit_end ->
+              ie_contM &
+                step
+                  ~sc:(SC.append sc (S.copy c))
+                  ~left:(left - S.length c)
+          ]
+      ]
+;
+
+
+value (limit : int -> enumeratee 'el 'el 'a) lim = fun it ->
+  let rec limit ~lim ~it =
+    let () = dbg "limit: lim=%i\n%!" lim in
+    match (lim, it) with
+    [ (_, (IE_done _ | IE_cont (Some _) _))
+      | (0, IE_cont None _) -> return it
+    | (lim, IE_cont None k) ->
+        ie_cont & step ~left:lim ~k
+    ]
+  and step ~left ~k s
+   : IO.m (iteratee 'el (iteratee 'el 'a) * stream 'el) =
+    match (s : stream 'el) with
+    [ EOF _ -> k s >>% fun (i, _) -> ie_doneM i s
+    | Chunk c ->
+        let len = S.length c in
+        let () = dbg "limit/step: len=%i\n%!" len in
+        if len <= left
+        then
+          k s >>% fun (it, s) ->
+          IO.return (limit ~lim:(left - len) ~it, s)
+        else
+          let (c1, c2) = S.split_at left c in
+          k (Chunk c1) >>% fun (it, s1') ->
+            let s' = Chunk (
+              match s1' with
+              [ Chunk c1' -> S.concat_splitted c1' c2
+              | EOF _ -> c2
+              ]) in
+            let () = dbg "limit: concated: %s\n%!" & dbgstream s' in
+            ie_doneM it s'
+    ]
+  in
+    limit ~lim ~it
+;
+
+
+value
+  (catchk : iteratee 'el 'a ->
+            ( err_msg ->
+              (stream 'el -> IO.m (iteratee 'el 'a  *  stream 'el)) ->
+              iteratee 'el 'a
+            ) ->
+            iteratee 'el 'a
+  ) it handler =
+  let rec catchk it =
+    match it with
+    [ IE_done _ -> it
+    | IE_cont (Some e) k -> handler e k
+    | IE_cont None k -> ie_cont & step k
+    ]
+  and step k s =
+    k s >>% fun (it, s) -> IO.return (catchk it, s)
+  in
+    let () = dbg "catchk: entered\n%!" in
+    catchk it
+;
+
+
+value
+  (catch : iteratee 'el 'a ->
+           ( err_msg ->
+             iteratee 'el 'a
+           ) ->
+           iteratee 'el 'a
+  ) it handler =
+  catchk it (fun err_msg _cont -> handler err_msg)
+;
+
+
+
+
+value printf fmt =
+  Printf.ksprintf (fun s -> lift & IO.write IO.stdout s) fmt
+;
+
+
 end
 ;  (* `Make' functor *)
+open Ocamlbuild_plugin;;
+
+
+
+(**********************)
+
+(* these functions are not really officially exported *)
+let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
+let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
+
+let split s ch =
+  let x = ref [] in
+  let rec go s =
+    let pos = String.index s ch in
+    x := (String.before s pos)::!x;
+    go (String.after s (pos + 1))
+  in
+  try
+    go s
+  with Not_found -> !x
+
+let split_nl s = split s '\n'
+
+let before_space s =
+  try
+    String.before s (String.index s ' ')
+  with Not_found -> s
+
+(* this lists all supported packages *)
+let find_packages () =
+  List.map before_space (split_nl & run_and_read "ocamlfind list")
+
+(* this is supposed to list available syntaxes,
+   but I don't know how to do it. *)
+let find_syntaxes () = ["camlp4o"; "camlp4r"]
+
+(* ocamlfind command *)
+let ocamlfind x = S[A"ocamlfind"; x]
+;;
+
+let disp_ocamlfind = begin function
+   | Before_options ->
+       (* by using Before_options one let command line options have an higher priority *)
+       (* on the contrary using After_options will guarantee to have the higher priority *)
+
+       (* override default commands by ocamlfind ones *)
+       Options.ocamlc     := ocamlfind & A"ocamlc";
+       Options.ocamlopt   := ocamlfind & A"ocamlopt";
+       Options.ocamldep   := ocamlfind & A"ocamldep" (* S[A"ocamldep"; A"-verbose"] *) ;
+       Options.ocamldoc   := ocamlfind & A"ocamldoc";
+       Options.ocamlmktop := ocamlfind & A"ocamlmktop"
+
+   | After_rules ->
+
+       (* When one link an OCaml library/binary/package, one should use -linkpkg *)
+       flag ["ocaml"; "link"] & A"-linkpkg";
+
+       (* For each ocamlfind package one inject the -package option when
+       	* compiling, computing dependencies, generating documentation and
+       	* linking. *)
+       List.iter begin fun pkg ->
+         flag ["ocaml"; "compile";  "pkg_"^pkg] & S[A"-package"; A pkg];
+         flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
+         flag ["ocaml"; "doc";      "pkg_"^pkg] & S[A"-package"; A pkg];
+         flag ["ocaml"; "link";     "pkg_"^pkg] & S[A"-package"; A pkg];
+         flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
+       end (find_packages ());
+
+       (* Like -package but for extensions syntax. Morover -syntax is useless
+       	* when linking. *)
+       List.iter begin fun syntax ->
+         flag ["ocaml"; "compile";  "syntax_"^syntax] & S[A"-syntax"; A syntax];
+         flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+         flag ["ocaml"; "doc";      "syntax_"^syntax] & S[A"-syntax"; A syntax];
+         flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+       end (find_syntaxes ());
+       
+       (* The default "thread" tag is not compatible with ocamlfind.
+          Indeed, the default rules add the "threads.cma" or "threads.cmxa"
+          options when using this tag. When using the "-linkpkg" option with
+          ocamlfind, this module will then be added twice on the command line.
+       
+          To solve this, one approach is to add the "-thread" option when using
+          the "threads" package using the previous plugin.
+        *)
+       flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
+       flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
+       flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
+       
+   | _ -> ()
+end
+
+(**********************)
+
+
+
+(*
+List.iter begin fun class_name ->
+  flag ["ocaml"; "pp"; "classes"^class_name] (S[A"-classes"; A class_name])
+end ["Show"; "Typeable"]
+;;
+*)
+
+let libdir = !Ocamlbuild_pack.Ocamlbuild_where.libdir
+;;
+
+(*
+Printf.printf "%!\n\n\nlibdir: %S\n\n\n%!"
+   !Ocamlbuild_pack.Ocamlbuild_where.libdir
+   !libdir
+   !Ocamlbuild_where.libdir
+   !Myocamlbuild_config.libdir
+   !Ocamlbuild_Myocamlbuild_config.libdir
+*)
+
+let stdlib_dir = Ocamlbuild_pack.Ocaml_utils.stdlib_dir;;
+
+
+let str_replace_char str cfrom cto =
+  let str = String.copy str in
+  let () =
+    for i = 0 to String.length str - 1 do
+      ( if str.[i] = cfrom
+        then str.[i] <- cto
+        else ()
+      )
+      done
+  in
+  str
+;;
+
+
+let disp_deriving = (function
+| After_rules ->
+    let stdlib_dir = Lazy.force stdlib_dir in
+    let syn_dir = stdlib_dir / "deriving" / "syntax" in
+(*
+    let syn_dir =
+      if Sys.os_type = "Win32"
+      then str_replace_char syn_dir '/' '\\'
+      else syn_dir
+    in
+*)
+    ( flag ["ocaml"; "pp"; "deriving"]
+        (S[A"-I"; P(syn_dir);
+          S(List.map
+              (fun m -> A(m^".cmo"))
+              ["utils"; "type"; "base"; "id"; "extend"; "show_class"]
+           )
+          ]
+        )
+    ; flag ["ocaml"; "compile"; "deriving"]
+        (S[A"-I"; P("+deriving" / "lib")])
+    ; flag ["ocaml"; "link"; "deriving"; "byte"]
+        (S[A"-I"; P("+deriving" / "lib"); A"deriving.cma"])
+    ; flag ["ocaml"; "link"; "deriving"; "native"]
+        (S[A"-I"; P("+deriving" / "lib"); A"deriving.cmxa"])
+    )
+|  _ -> ()
+);;
+
+
+dispatch
+(fun x -> (disp_ocamlfind x; disp_deriving x))
+;;
-@call c:\overbld\ocaml\set-vars.bat
+@call d:\overbld\ocaml\set-vars.bat
 @bash run.sh
 EXT="byte"
 TARGETS="iteratees.$EXT tests_direct.$EXT"
 # bash
+
+# ocamlbuild iteratees.inferred.mli && \
+#   grep -A 5 "val limit" _build/iteratees.inferred.mli
+# exit
+
 rm -f $TARGETS && ocamlbuild iteratees.inferred.mli $TARGETS && \
   (for X in $TARGETS;
    do
 
 
 (* +
+   [break_limit ~limit pred s] looks at first [limit] elements.
+   If found element matching [pred], then [`Found (prefix, rest)]
+   returned.  If the limit is hit, then [`Hit_limit] returned
+   (so, if it is ok for you, use [split_at limit s] to get pieces).
+   If the end of chunk is hit, then [`Hit_end] returned (and
+   the whole [s] does not match [pred]).
+   If [limit = length s] and no elements found, then [`Hit_limit]
+   returned (limit has more priority than chunk's end).
+*)
+
+value break_limit ~limit pred s =
+  inner 0
+  where rec inner i =
+    if i = limit
+    then
+      `Hit_limit
+    else
+      if i = s.len
+      then
+        `Hit_end
+      else
+        if pred s.arr.(s.ofs + i)
+        then
+          `Found (split_at i s)
+        else
+          inner (i + 1)
+;
+
+
+(* +
    [drop_while pred s] returns the remaining "substring" of [s]
    which remains after cutting off the longest prefix (possibly empty)
    of [s] of elements that satisfy predicate [pred].
   Array.init s.len &
   fun i -> s.arr.(s.ofs + i)
 ;
+
+value copy s =
+  mk ~arr:(Array.sub s.arr s.ofs s.len) ~ofs:0 ~len:s.len
+;
+
+
+(* concatenate previously splitted pieces (b follows a) *)
+
+value concat_splitted a b =
+  match (a.len, b.len) with
+  [ (0, _) -> b
+  | (_, 0) -> a
+  | (alen, blen) ->
+      if a.arr != b.arr then invalid_arg "Subarray.concat: arr" else
+      if a.ofs + alen <> b.ofs then invalid_arg "S.concat: ranges" else
+      C.mk ~arr:a.arr ~ofs:a.ofs ~len:(alen + blen)
+  ]
+;
+open Ops
+;
+
+module S = Subarray
+;
+
+type t 'a = array (Subarray.t 'a)
+;
+
+value (array_filter : ('a -> bool) -> array 'a -> array 'a) pred arr =
+  let bads = Array.fold_left
+    (fun count x -> count + if not & pred x then 1 else 0)
+    0
+    arr
+  in
+  if bads = 0
+  then arr
+  else
+    let new_len = Array.length arr - bads in
+    if new_len = 0
+    then [| |]
+    else
+      let res = Array.make new_len arr.(0)
+      and i = ref 0 in
+      ( Array.iter
+          (fun x ->
+             if pred x
+             then
+               ( res.(i.val) := x
+               ; incr i
+               )
+             else ()
+          )
+          arr
+      ; res
+      )
+;
+
+value make_of_array arr =
+  array_filter (fun s -> S.length s <> 0) arr
+;
+
+value make lst = make_of_array & Array.of_list lst
+;
+
+value (append_array : array 'a -> 'a -> array 'a) src s =
+  let src_len = Array.length src in
+  Array.init (src_len + 1) & fun i ->
+    if i = src_len
+    then s
+    else src.(i)
+;
+
+value append src s =
+  make_of_array & append_array src s
+;
+
+value length sc =
+  Array.fold_left (fun acc s -> acc + S.length s) 0 sc
+;
+
+value outof () = invalid_arg "Subarray_cat.get"
+;
+
+value get sc i =
+  if i < 0
+  then outof ()
+  else
+    let sc_len = Array.length sc in
+    inner ~i ~j:0
+    where rec inner ~i ~j =
+      if j = sc_len
+      then outof ()
+      else
+        let sj = sc.(j) in
+        let sj_len = S.length sj in
+        if i < sj_len
+        then
+          S.get sj i
+        else
+          inner ~i:(i - sj_len) ~j:(j+1)
+;
+
+value sub_copy_out ?(ofs=0) ?len sc =
+  let len =
+    match len with
+    [ None -> length sc - ofs
+    | Some len -> len
+    ]
+  in
+  let sc_len = length sc in
+  if ofs < 0 || len < 0 || ofs+len > sc_len
+  then invalid_arg "Subarray_cat.sub_copy_out"
+  else
+  S.of_array & Array.init len (fun i -> get sc (ofs+i))
+;
+(* concatenated subarrays holding values of type ['a] *)
+type t 'a;
+
+value make : list (Subarray.t 'a) -> t 'a;
+
+(* [length sc] returns count of elements stored in all subarrays
+   contained in [sc]
+*)
+value length : t 'a -> int;
+
+(* [get sc i] gets item from concatenated subarrays [sc]
+   by global index [i] (from [0] to [length sc - 1]).
+   Raises [Invalid_argument "Subarray_cat.get"] when
+   [i] is out of bounds. *)
+value get : t 'a -> int -> 'a;
+
+(* [sub_copy_out sc ~ofs ~len] copies items from
+   global offset [ofs] and length [len] from concatenated
+   subarrays [sc] into freshly created subarray. *)
+value sub_copy_out : ?ofs:int -> ?len:int -> t 'a -> Subarray.t 'a;
+
+(* [append sc s] appends subarray [s] to the end of
+   concatenated subarrays [sc].
+*)
+value append : t 'a -> Subarray.t 'a -> t 'a;
 
 (* +
    This is my test for enumeratee that transforms iteratee over
-   utf8 chars (type [It_misc.uchar]) to iteratee over octets (type [char]).
+   utf8 chars (type [I.UTF8.uchar]) to iteratee over octets (type [char]).
 *)
 
-module U = It_misc.UTF8(IO);
+module U = I.UTF8;
 
 value (dump_utf8_chars : iteratee U.uchar unit) =
  let pr s = mprintf "dump_utf8_chars: %s\n" s in
 
 
 
+value limit_chars = expl "12345678abcdefgh"
+;
+
+
+exception Bad_int of string
+;
+
+
+value limited_iteratee : iteratee char int =
+  let is_digit = fun [ '0'..'9' -> True | _ -> False ] in
+  break_chars (not % is_digit) >>= fun num_str ->
+  try return & int_of_string num_str
+  with [ Failure _ -> throw_err & Bad_int num_str ]
+;
+
+
+value test_limit ~feed_cont n =
+ let () = printf "test_limit: n=%i, feed_cont=%b\n%!" n feed_cont in
+ let ctch ~b it =
+   if not b
+   then
+     it
+   else
+     catchk
+      it
+      (fun err_msg _cont ->
+         let () = printf "limited: caught %s%!" &
+           match err_msg with
+           [ Iteratees_err_msg e | e -> Printexc.to_string e ]
+         in
+           throw_err err_msg
+      )
+ in
+ try
+  let res = runA &
+    (enum_pure_nchunk limit_chars 3)
+    ( ctch ~b:True
+        ( (limit n limited_iteratee) >>= fun it ->
+          ( match it with
+            [ IE_done i -> return & Some i
+            | IE_cont None cont ->
+                let () = printf "limited: cont wants more data, %!" in
+                if not feed_cont
+                then
+                  let () = printf "ignoring.\n%!" in
+                  lift (cont (EOF None)) >>= fun _ ->
+                  return None
+                else
+                  let () = printf "feeding.\n%!" in
+                  ie_cont cont >>= fun i ->
+                  return & Some i
+            | IE_cont (Some e) _ ->
+                let () = printf "limited: error: %s\n" & Printexc.to_string e
+                in
+                  return None
+            ]) >>= fun oi ->
+          break_chars (fun _ -> False) >>= fun str ->
+          return (oi, str)
+        )
+    )
+  in
+  match res with
+  [ `Ok (oi, str) ->
+      Printf.printf "limited: i=%s str=%S\n\n%!"
+        (match oi with
+         [ None -> "None"
+         | Some i -> string_of_int i
+         ])
+        str
+  | `Error e -> Printf.printf "exn: %s\n\n%!" &
+      match e with
+      [ Iteratees_err_msg e | e -> Printexc.to_string e
+      ]
+  ]
+ with
+ [ e -> Printf.printf "ACHTUNG!  uncaught exn: %s\n%!" & Printexc.to_string e ]
+;
+
+
+(*
+
+    ( ctch ~b:True
+        ( (joinI & limit n limited_iteratee) >>= fun i ->
+          break_chars (fun _ -> False) >>= fun str ->
+          return (i, str)
+        )
+    )
+
+*)
+
+
+value test_limits () =
+  ( printf "\n%!"
+  ; test_limit ~feed_cont:False 10
+  ; test_limit ~feed_cont:False 5
+  ; test_limit ~feed_cont:True 5
+  )
+;
+
+
 value () =
   ( printf "TESTS BEGIN.\n"
 
 
   ; test_utf8_enumeratee ()
 
+  ; test_limits ()
+
   ; printf "TESTS END.\n"
   );
 
+open Tests_common;
+
+open It_Lwt_IO;
+
+module T = Tests_functor(It_Lwt_IO);
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.