Anonymous avatar Anonymous committed e082581

stripped CRs

Comments (0)

Files changed (9)

-LGPL with linking exception
+LGPL with linking exception
-(*
-value dbg fmt = Printf.printf fmt
-;
-*)
-
-value dbg fmt = Printf.ifprintf Pervasives.stdout fmt
-;
+(*
+value dbg fmt = Printf.printf fmt
+;
+*)
+
+value dbg fmt = Printf.ifprintf Pervasives.stdout fmt
+;
-open Types
-;
-
-(* OCaml Pervasives IO *)
-
-value res_of_exn e : res 'a = `Error e
-;
-
-module Direct_IO
- :
-  sig
-    type m +'a = res '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;
-    value stdout : output_channel;
-    value write : output_channel -> string -> m unit;
-
-    type 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;
-
-  end
- =
-  struct
-    type m +'a = res 'a;
-    value return x = `Ok x;
-    value bind f m =
-      match m with
-      [ `Ok r -> f r
-      | `Error ep -> `Error ep
-      ]
-    ;
-    value ( >>= ) m f = bind f m;
-
-    value catch f handler =
-      match f () with
-      [ (`Ok _) as r -> r
-      | `Error ep -> handler ep
-      ]
-    ;
-
-(*
-    value try_bind m f handler =
-      catch (fun () -> m () >>= f) handler
-    ;
-*)
-
-(*
-    value read_into in_ch buf ofs len = fun () ->
-      try `Ok (Pervasives.input in_ch buf ofs len)
-      with [ e -> res_of_exn e ]
-    ;
-*)
-    value wrap1 place f = fun a ->
-      try `Ok (f a)
-      with [ e -> res_of_exn (EIO (e, place)) ]
-    ;
-    value wrap2 place f = fun a b ->
-      try `Ok (f a b)
-      with [ e -> res_of_exn (EIO (e, place)) ]
-    ;
-    value wrap4 place f = fun a b c d ->
-      try `Ok (f a b c d)
-      with [ e -> res_of_exn (EIO (e, place)) ]
-    ;
-
-    value read_into = wrap4 "read_into" Pervasives.input;
-
-    value error = res_of_exn;
-
-    type output_channel = Pervasives.out_channel;
-    value stdout = Pervasives.stdout;
-    value write = wrap2 "write" Pervasives.output_string;
-
-    type input_channel = Pervasives.in_channel;
-    value open_in = wrap1 "open_in" Pervasives.open_in_bin;
-    value close_in = wrap1 "close_in" Pervasives.close_in;
-
-    value runIO x = x;
-
-  end
-;
+open Types
+;
+
+(* OCaml Pervasives IO *)
+
+value res_of_exn e : res 'a = `Error e
+;
+
+module Direct_IO
+ :
+  sig
+    type m +'a = res '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;
+    value stdout : output_channel;
+    value write : output_channel -> string -> m unit;
+
+    type 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;
+
+  end
+ =
+  struct
+    type m +'a = res 'a;
+    value return x = `Ok x;
+    value bind f m =
+      match m with
+      [ `Ok r -> f r
+      | `Error ep -> `Error ep
+      ]
+    ;
+    value ( >>= ) m f = bind f m;
+
+    value catch f handler =
+      match f () with
+      [ (`Ok _) as r -> r
+      | `Error ep -> handler ep
+      ]
+    ;
+
+(*
+    value try_bind m f handler =
+      catch (fun () -> m () >>= f) handler
+    ;
+*)
+
+(*
+    value read_into in_ch buf ofs len = fun () ->
+      try `Ok (Pervasives.input in_ch buf ofs len)
+      with [ e -> res_of_exn e ]
+    ;
+*)
+    value wrap1 place f = fun a ->
+      try `Ok (f a)
+      with [ e -> res_of_exn (EIO (e, place)) ]
+    ;
+    value wrap2 place f = fun a b ->
+      try `Ok (f a b)
+      with [ e -> res_of_exn (EIO (e, place)) ]
+    ;
+    value wrap4 place f = fun a b c d ->
+      try `Ok (f a b c d)
+      with [ e -> res_of_exn (EIO (e, place)) ]
+    ;
+
+    value read_into = wrap4 "read_into" Pervasives.input;
+
+    value error = res_of_exn;
+
+    type output_channel = Pervasives.out_channel;
+    value stdout = Pervasives.stdout;
+    value write = wrap2 "write" Pervasives.output_string;
+
+    type input_channel = Pervasives.in_channel;
+    value open_in = wrap1 "open_in" Pervasives.open_in_bin;
+    value close_in = wrap1 "close_in" Pervasives.close_in;
+
+    value runIO x = x;
+
+  end
+;

iteratees_http.ml

-open Types
-;
-
-open Dbg
-;
-
-open Ops
-;
-
-module It_http (IO : MonadIO) =
-struct
-
-open Iteratees
-;
-
-module I = Make(IO)
-;
-
-open I
-;
-
-
-(* Combining the primitive iteratees to solve the running problem:
-   Reading headers and the content from an HTTP-like stream
-*)
-
-type line = string  (* The line of text, terminators are not included *)
-;
-
-
-(* Read the line of text from the stream
-   The line can be terminated by CR, LF or CRLF.
-   Return (Right Line) if successful. Return (Left Line) if EOF or
-   a stream error were encountered before the terminator is seen.
-   The returned line is the string read so far.
-   This is a totally high-level Iteratee, built by composing low-level
-   ones. It knows nothing about the representation of Iteratees.
-*)
-
-value (line : iteratee char ([= `No_term | `Term] * line)) =
-  let lf = ['\n'] in
-  let crlf = ['\r'; '\n'] in
-  let check l ts =
-    return & ((if ts = 0 then `No_term else `Term), l)
-  in
-  let terminators =
-    heads crlf >>= fun n ->
-    if n == 0
-    then heads lf
-    else return n
-  in
-    break_chars (fun c -> c == '\r' || c == '\n') >>= fun l ->
-let () = dbg "http_line: %S\n" l in
-    terminators >>= fun ts ->
-    check l ts
-;
-
-
-(* Line iteratees: processors of a stream whose elements are made of Lines
-
-   Print lines as they are received. This is the first `impure' iteratee
-   with non-trivial actions during chunk processing
-*)
-
-value (print_lines : iteratee line unit) =
-  let pr_line l = print_line (">> read line: " ^ l)
-  in
-  ie_cont step
-  where rec step s =
-    match s with
-    [ Chunk c ->
-        let lst = S.to_list c in
-        if lst = []
-        then ie_contM step
-        else io_iter pr_line lst >>% fun () -> ie_contM step
-    | EOF e ->
-        pr_line
-          (if e = None
-           then ">> natural end"
-           else ">> unnatural end"
-          ) >>% fun () ->
-        ie_doneM () s
-    ]
-;
-
-
-(* Combining the primitive iteratees to solve the running problem:
-   Reading headers and the content from an HTTP-like stream
-
-   Convert the stream of characters to the stream of lines, and
-   apply the given iteratee to enumerate the latter.
-   The stream of lines is normally terminated by the empty line.
-   When the stream of characters is terminated, the stream of lines
-   is also terminated, abnormally.
-   This is the first proper Enumeratee: it is the iteratee of the
-   character stream and the enumerator of the line stream.
-   More generally, we could have used sequence_stream to implement enum_lines.
-*)
-
-exception Non_terminated_lines
-;
-
-value rec (enum_lines : enumeratee char string 'a) i =
-  match i with
-  [ IE_cont None k ->
-let () = dbg "enum_lines: IE_cont\n" in
-      line >>= fun term_line ->
-        match term_line with
-        [ (`Term, "") ->
-let () = dbg "enum_lines:   empty line\n" in
-            return i  (* empty line, normal exit *)
-        | (`Term, l) ->
-let () = dbg "enum_lines:   term: %S\n" l in
-            liftI (
-            k (chunk_of l) >>% fun (i, _s) ->
-            IO.return (enum_lines i)
-            )
-        | (`No_term, l) ->
-let () = dbg "enum_lines:   non-term: %S\n" l in
-            (lift : _)
-            (k (if l="" then EOF (Some End_of_file) else chunk_of l)
-             >>% fun (i, _s) ->
-             enum_err End_of_file i
-            )
-        ]
-  | IE_cont (Some _) _ ->
-let () = dbg "enum_lines: error\n" in
-      return i
-  | IE_done _ ->
-let () = dbg "enum_lines: done\n" in
-      return i
-  ]
-;
-
-
-(* HTTP chunk decoding
-   Each chunk has the following format:
-
-   	  <chunk-size> CRLF <chunk-data> CRLF
-  
-   where <chunk-size> is the hexadecimal number; <chunk-data> is a
-   sequence of <chunk-size> bytes.
-   The last chunk (so-called EOF chunk) has the format
-   0 CRLF CRLF (where 0 is an ASCII zero, a character with the decimal code 48).
-   For more detail, see "Chunked Transfer Coding", Sec 3.6.1 of
-   the HTTP/1.1 standard:
-   http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.6.1
-
-   The following enum_chunk_decoded has the signature of the enumerator
-   of the nested (encapsulated and chunk-encoded) stream. It receives
-   an iteratee for the embedded stream and returns the iteratee for
-   the base, embedding stream. Thus what is an enumerator and what
-   is an iteratee may be a matter of perspective.
-
-   We have a decision to make: Suppose an iteratee has finished (either because
-   it obtained all needed data or encountered an error that makes further
-   processing meaningless). While skipping the rest of the stream/the trailer,
-   we encountered a framing error (e.g., missing CRLF after chunk data).
-   What do we do? We chose to disregard the latter problem.
-   Rationale: when the iteratee has finished, we are in the process
-   of skipping up to the EOF (draining the source).
-   Disregarding the errors seems OK then.
-   Also, the iteratee may have found an error and decided to abort further
-   processing. Flushing the remainder of the input is reasonable then.
-   One can make a different choice...
-*)
-
-exception EChunked of string;
-
-value (enum_chunk_decoded : enumeratee char char 'a) iter =
-  let rec (enum_chunk_decoded : enumeratee char char 'a) iter =
-    break_chars ( (=) '\r') >>= fun size_str ->
-    match size_str with
-    [ "" -> frame_err (exc "Error reading chunk size") iter
-    | str ->  (* todo: ptso *)
-        match read_hex str with
-        [ None -> frame_err (exc ("Bad chunk size: " ^ str)) iter
-        | Some size ->
-            let () = dbg "enum_chunk_decoded: frame %i (%x) bytes\n" size size in
-            getCRLF iter (
-            take size iter >>= fun r ->
-            getCRLF r (
-            if size = 0
-            then return r
-            else enum_chunk_decoded r
-            ))
-        ]
-    ]
-
-  and getCRLF iter m =
-    heads ['\r'; '\n'] >>= fun n ->
-    if n = 2
-    then m
-    else frame_err (exc "Bad Chunk: no CRLF") iter
-
-  and read_hex x =
-    try Scanf.sscanf x "%x%!" (fun i -> Some i)
-    with [ Scanf.Scan_failure _ -> None ]
-
-  and exc msg = EChunked msg
-
-  (* If the processing is restarted, we report the frame error to the inner
-    Iteratee, and exit
-  *)
-  and frame_err e iter =
-    throw_recoverable_err (exc "Frame error")
-    (fun s -> enum_err e iter >>% fun i -> IO.return (return i, s))
-  in
-    enum_chunk_decoded iter
-;
-
-end;
+open Types
+;
+
+open Dbg
+;
+
+open Ops
+;
+
+module It_http (IO : MonadIO) =
+struct
+
+open Iteratees
+;
+
+module I = Make(IO)
+;
+
+open I
+;
+
+
+(* Combining the primitive iteratees to solve the running problem:
+   Reading headers and the content from an HTTP-like stream
+*)
+
+type line = string  (* The line of text, terminators are not included *)
+;
+
+
+(* Read the line of text from the stream
+   The line can be terminated by CR, LF or CRLF.
+   Return (Right Line) if successful. Return (Left Line) if EOF or
+   a stream error were encountered before the terminator is seen.
+   The returned line is the string read so far.
+   This is a totally high-level Iteratee, built by composing low-level
+   ones. It knows nothing about the representation of Iteratees.
+*)
+
+value (line : iteratee char ([= `No_term | `Term] * line)) =
+  let lf = ['\n'] in
+  let crlf = ['\r'; '\n'] in
+  let check l ts =
+    return & ((if ts = 0 then `No_term else `Term), l)
+  in
+  let terminators =
+    heads crlf >>= fun n ->
+    if n == 0
+    then heads lf
+    else return n
+  in
+    break_chars (fun c -> c == '\r' || c == '\n') >>= fun l ->
+let () = dbg "http_line: %S\n" l in
+    terminators >>= fun ts ->
+    check l ts
+;
+
+
+(* Line iteratees: processors of a stream whose elements are made of Lines
+
+   Print lines as they are received. This is the first `impure' iteratee
+   with non-trivial actions during chunk processing
+*)
+
+value (print_lines : iteratee line unit) =
+  let pr_line l = print_line (">> read line: " ^ l)
+  in
+  ie_cont step
+  where rec step s =
+    match s with
+    [ Chunk c ->
+        let lst = S.to_list c in
+        if lst = []
+        then ie_contM step
+        else io_iter pr_line lst >>% fun () -> ie_contM step
+    | EOF e ->
+        pr_line
+          (if e = None
+           then ">> natural end"
+           else ">> unnatural end"
+          ) >>% fun () ->
+        ie_doneM () s
+    ]
+;
+
+
+(* Combining the primitive iteratees to solve the running problem:
+   Reading headers and the content from an HTTP-like stream
+
+   Convert the stream of characters to the stream of lines, and
+   apply the given iteratee to enumerate the latter.
+   The stream of lines is normally terminated by the empty line.
+   When the stream of characters is terminated, the stream of lines
+   is also terminated, abnormally.
+   This is the first proper Enumeratee: it is the iteratee of the
+   character stream and the enumerator of the line stream.
+   More generally, we could have used sequence_stream to implement enum_lines.
+*)
+
+exception Non_terminated_lines
+;
+
+value rec (enum_lines : enumeratee char string 'a) i =
+  match i with
+  [ IE_cont None k ->
+let () = dbg "enum_lines: IE_cont\n" in
+      line >>= fun term_line ->
+        match term_line with
+        [ (`Term, "") ->
+let () = dbg "enum_lines:   empty line\n" in
+            return i  (* empty line, normal exit *)
+        | (`Term, l) ->
+let () = dbg "enum_lines:   term: %S\n" l in
+            liftI (
+            k (chunk_of l) >>% fun (i, _s) ->
+            IO.return (enum_lines i)
+            )
+        | (`No_term, l) ->
+let () = dbg "enum_lines:   non-term: %S\n" l in
+            (lift : _)
+            (k (if l="" then EOF (Some End_of_file) else chunk_of l)
+             >>% fun (i, _s) ->
+             enum_err End_of_file i
+            )
+        ]
+  | IE_cont (Some _) _ ->
+let () = dbg "enum_lines: error\n" in
+      return i
+  | IE_done _ ->
+let () = dbg "enum_lines: done\n" in
+      return i
+  ]
+;
+
+
+(* HTTP chunk decoding
+   Each chunk has the following format:
+
+   	  <chunk-size> CRLF <chunk-data> CRLF
+  
+   where <chunk-size> is the hexadecimal number; <chunk-data> is a
+   sequence of <chunk-size> bytes.
+   The last chunk (so-called EOF chunk) has the format
+   0 CRLF CRLF (where 0 is an ASCII zero, a character with the decimal code 48).
+   For more detail, see "Chunked Transfer Coding", Sec 3.6.1 of
+   the HTTP/1.1 standard:
+   http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.6.1
+
+   The following enum_chunk_decoded has the signature of the enumerator
+   of the nested (encapsulated and chunk-encoded) stream. It receives
+   an iteratee for the embedded stream and returns the iteratee for
+   the base, embedding stream. Thus what is an enumerator and what
+   is an iteratee may be a matter of perspective.
+
+   We have a decision to make: Suppose an iteratee has finished (either because
+   it obtained all needed data or encountered an error that makes further
+   processing meaningless). While skipping the rest of the stream/the trailer,
+   we encountered a framing error (e.g., missing CRLF after chunk data).
+   What do we do? We chose to disregard the latter problem.
+   Rationale: when the iteratee has finished, we are in the process
+   of skipping up to the EOF (draining the source).
+   Disregarding the errors seems OK then.
+   Also, the iteratee may have found an error and decided to abort further
+   processing. Flushing the remainder of the input is reasonable then.
+   One can make a different choice...
+*)
+
+exception EChunked of string;
+
+value (enum_chunk_decoded : enumeratee char char 'a) iter =
+  let rec (enum_chunk_decoded : enumeratee char char 'a) iter =
+    break_chars ( (=) '\r') >>= fun size_str ->
+    match size_str with
+    [ "" -> frame_err (exc "Error reading chunk size") iter
+    | str ->  (* todo: ptso *)
+        match read_hex str with
+        [ None -> frame_err (exc ("Bad chunk size: " ^ str)) iter
+        | Some size ->
+            let () = dbg "enum_chunk_decoded: frame %i (%x) bytes\n" size size in
+            getCRLF iter (
+            take size iter >>= fun r ->
+            getCRLF r (
+            if size = 0
+            then return r
+            else enum_chunk_decoded r
+            ))
+        ]
+    ]
+
+  and getCRLF iter m =
+    heads ['\r'; '\n'] >>= fun n ->
+    if n = 2
+    then m
+    else frame_err (exc "Bad Chunk: no CRLF") iter
+
+  and read_hex x =
+    try Scanf.sscanf x "%x%!" (fun i -> Some i)
+    with [ Scanf.Scan_failure _ -> None ]
+
+  and exc msg = EChunked msg
+
+  (* If the processing is restarted, we report the frame error to the inner
+    Iteratee, and exit
+  *)
+  and frame_err e iter =
+    throw_recoverable_err (exc "Frame error")
+    (fun s -> enum_err e iter >>% fun i -> IO.return (return i, s))
+  in
+    enum_chunk_decoded iter
+;
+
+end;
-let some x = Some x
-
-(** пропустить значение последовательно через функции:
-    123 >> string_of_int >> print_string
-*)
-let ( >> ) x f = f x
-
-(** применить значение к функции:
-    print_string & string_of_int & 123
-
-    NB: оператор "&" является ключевым словом в jocaml
-
-    Если попробовать объявить "let ( $ ) f x = f x",
-    то полученный оператор будет левоассоциативным,
-    что нежелательно в данном случае.
-*)
-let ( & ) f x = f x
-
-(** композиция функций:
-    let print_int = print_string % string_of_int
-    let print_int = print_string $ string_of_int
-    let print_int_sum = print_string % string_of_int %% ( + )
-    let print_int_sum = print_string %% (string_of_int %% ( + ) )
-    let for_all pred = not % List.exists (not % pred)
-    let for_all2 pred = not %% List.exists2 (not %% pred)
-
-    Операторы левоассоциативны, у оператора ($) приоритет ниже,
-    чем у (%), и ниже, чем у арифметических операторов.
-*)
-let ( % ) f g = fun x -> f (g x)
-let ( $ ) = ( % )
-let ( %% ) f g = fun x y -> f (g x y)
-let ( %%% ) f g = fun x y z -> f (g x y z)
-
-(** применить инфиксную функцию:
-    123L /* Int64.add */ 234L
-*)
-let ( /* ) x y = y x
-let ( */ ) x y = x y
-
-
-(* Для удобного использования инфиксных операторов
-   существует отличное решение: pa_do
-   ( http://pa-do.forge.ocamlcore.org/ )
-   Если использовать его не можете, то в качестве
-   слабого подобия можно взять нижеследующие модули.
-   Их названия имеют вид "Тип1_as_тип2", и при открытии
-   такого модуля со значениями типа1 можно будет работать
-   теми операторами, которыми обычно работают со значениями
-   типа2.
-   Например,
-   let my_int64 =
-     let module M =
-       struct
-         open Int32_as_int
-         open Int64_as_float
-         let x = (Int64.of_int32 (123l + 234l)) +. 345L
-       end
-     in
-       M.x
-*)
-
-(* Замечание: для консистентности модули "Тип1_as_тип2"
-   всегда должны переопределять одни и те же операторы.
-*)
-
-(* todo: добавить в Int* операции mod, rem, битовые *)
-
-module Int_as_int =
-  struct
-    let ( + ) = Pervasives.( + )
-    let ( - ) = Pervasives.( - )
-    let ( * ) = Pervasives.( * )
-    let ( / ) = Pervasives.( / )
-    let ( ~- ) = Pervasives.( ~- )
-  end
-
-module Float_as_float =
-  struct
-    let ( +. ) = Pervasives.( +. )
-    let ( -. ) = Pervasives.( -. )
-    let ( *. ) = Pervasives.( *. )
-    let ( /. ) = Pervasives.( /. )
-    let ( ~-. ) = Pervasives.( ~-. )
-  end
-
-
-(** TODO core, pa_do, pa_openin *)
-
-module Int32_as_int =
-  struct
-    let ( + ) = Int32.add
-    let ( - ) = Int32.sub
-    let ( * ) = Int32.mul
-    let ( / ) = Int32.div
-    let ( ~- ) = Int32.neg
-  end
-
-module Int64_as_int =
-  struct
-    let ( + ) = Int64.add
-    let ( - ) = Int64.sub
-    let ( * ) = Int64.mul
-    let ( / ) = Int64.div
-    let ( ~- ) = Int64.neg
-  end
-
-module Int_as_float =
-  struct
-    let ( +. ) = Pervasives.( + )
-    let ( -. ) = Pervasives.( - )
-    let ( *. ) = Pervasives.( * )
-    let ( /. ) = Pervasives.( / )
-    let ( ~-. ) = Pervasives.( ~- )
-  end
-
-module Float_as_int =
-  struct
-    let ( + ) = Pervasives.( +. )
-    let ( - ) = Pervasives.( -. )
-    let ( * ) = Pervasives.( *. )
-    let ( / ) = Pervasives.( /. )
-    let ( ~- ) = Pervasives.( ~-. )
-  end
-
-module Int32_as_float =
-  struct
-    let ( +. ) = Int32.add
-    let ( -. ) = Int32.sub
-    let ( *. ) = Int32.mul
-    let ( /. ) = Int32.div
-    let ( ~-. ) = Int32.neg
-  end
-
-module Int64_as_float =
-  struct
-    let ( +. ) = Int64.add
-    let ( -. ) = Int64.sub
-    let ( *. ) = Int64.mul
-    let ( /. ) = Int64.div
-    let ( ~-. ) = Int64.neg
-  end
-
-module Int_as_int_overflow =
-  (* from http://alan.petitepomme.net/cwn/2004.06.22.html *)
-  struct
-    exception Overflow
-
-    let ( + ) a b =
-      let c = a + b in
-      if (a lxor b) lor (a lxor (lnot c)) < 0 then c else raise Overflow
-
-    let ( - ) a b =
-      let c = a - b in
-      if (a lxor (lnot b)) lor (b lxor c) < 0 then c else raise Overflow
-
-    let ( * ) a b =
-      let c = a * b in
-      if Int64.of_int c = Int64.mul (Int64.of_int a) (Int64.of_int b)
-      then c else raise Overflow
-
-    let ( / ) a b =
-      if a = min_int && b = -1 then raise Overflow else a / b
-
-    let ( ~- ) x =
-      if x <> min_int then -x else raise Overflow
-
-  end
+let some x = Some x
+
+(** пропустить значение последовательно через функции:
+    123 >> string_of_int >> print_string
+*)
+let ( >> ) x f = f x
+
+(** применить значение к функции:
+    print_string & string_of_int & 123
+
+    NB: оператор "&" является ключевым словом в jocaml
+
+    Если попробовать объявить "let ( $ ) f x = f x",
+    то полученный оператор будет левоассоциативным,
+    что нежелательно в данном случае.
+*)
+let ( & ) f x = f x
+
+(** композиция функций:
+    let print_int = print_string % string_of_int
+    let print_int = print_string $ string_of_int
+    let print_int_sum = print_string % string_of_int %% ( + )
+    let print_int_sum = print_string %% (string_of_int %% ( + ) )
+    let for_all pred = not % List.exists (not % pred)
+    let for_all2 pred = not %% List.exists2 (not %% pred)
+
+    Операторы левоассоциативны, у оператора ($) приоритет ниже,
+    чем у (%), и ниже, чем у арифметических операторов.
+*)
+let ( % ) f g = fun x -> f (g x)
+let ( $ ) = ( % )
+let ( %% ) f g = fun x y -> f (g x y)
+let ( %%% ) f g = fun x y z -> f (g x y z)
+
+(** применить инфиксную функцию:
+    123L /* Int64.add */ 234L
+*)
+let ( /* ) x y = y x
+let ( */ ) x y = x y
+
+
+(* Для удобного использования инфиксных операторов
+   существует отличное решение: pa_do
+   ( http://pa-do.forge.ocamlcore.org/ )
+   Если использовать его не можете, то в качестве
+   слабого подобия можно взять нижеследующие модули.
+   Их названия имеют вид "Тип1_as_тип2", и при открытии
+   такого модуля со значениями типа1 можно будет работать
+   теми операторами, которыми обычно работают со значениями
+   типа2.
+   Например,
+   let my_int64 =
+     let module M =
+       struct
+         open Int32_as_int
+         open Int64_as_float
+         let x = (Int64.of_int32 (123l + 234l)) +. 345L
+       end
+     in
+       M.x
+*)
+
+(* Замечание: для консистентности модули "Тип1_as_тип2"
+   всегда должны переопределять одни и те же операторы.
+*)
+
+(* todo: добавить в Int* операции mod, rem, битовые *)
+
+module Int_as_int =
+  struct
+    let ( + ) = Pervasives.( + )
+    let ( - ) = Pervasives.( - )
+    let ( * ) = Pervasives.( * )
+    let ( / ) = Pervasives.( / )
+    let ( ~- ) = Pervasives.( ~- )
+  end
+
+module Float_as_float =
+  struct
+    let ( +. ) = Pervasives.( +. )
+    let ( -. ) = Pervasives.( -. )
+    let ( *. ) = Pervasives.( *. )
+    let ( /. ) = Pervasives.( /. )
+    let ( ~-. ) = Pervasives.( ~-. )
+  end
+
+
+(** TODO core, pa_do, pa_openin *)
+
+module Int32_as_int =
+  struct
+    let ( + ) = Int32.add
+    let ( - ) = Int32.sub
+    let ( * ) = Int32.mul
+    let ( / ) = Int32.div
+    let ( ~- ) = Int32.neg
+  end
+
+module Int64_as_int =
+  struct
+    let ( + ) = Int64.add
+    let ( - ) = Int64.sub
+    let ( * ) = Int64.mul
+    let ( / ) = Int64.div
+    let ( ~- ) = Int64.neg
+  end
+
+module Int_as_float =
+  struct
+    let ( +. ) = Pervasives.( + )
+    let ( -. ) = Pervasives.( - )
+    let ( *. ) = Pervasives.( * )
+    let ( /. ) = Pervasives.( / )
+    let ( ~-. ) = Pervasives.( ~- )
+  end
+
+module Float_as_int =
+  struct
+    let ( + ) = Pervasives.( +. )
+    let ( - ) = Pervasives.( -. )
+    let ( * ) = Pervasives.( *. )
+    let ( / ) = Pervasives.( /. )
+    let ( ~- ) = Pervasives.( ~-. )
+  end
+
+module Int32_as_float =
+  struct
+    let ( +. ) = Int32.add
+    let ( -. ) = Int32.sub
+    let ( *. ) = Int32.mul
+    let ( /. ) = Int32.div
+    let ( ~-. ) = Int32.neg
+  end
+
+module Int64_as_float =
+  struct
+    let ( +. ) = Int64.add
+    let ( -. ) = Int64.sub
+    let ( *. ) = Int64.mul
+    let ( /. ) = Int64.div
+    let ( ~-. ) = Int64.neg
+  end
+
+module Int_as_int_overflow =
+  (* from http://alan.petitepomme.net/cwn/2004.06.22.html *)
+  struct
+    exception Overflow
+
+    let ( + ) a b =
+      let c = a + b in
+      if (a lxor b) lor (a lxor (lnot c)) < 0 then c else raise Overflow
+
+    let ( - ) a b =
+      let c = a - b in
+      if (a lxor (lnot b)) lor (b lxor c) < 0 then c else raise Overflow
+
+    let ( * ) a b =
+      let c = a * b in
+      if Int64.of_int c = Int64.mul (Int64.of_int a) (Int64.of_int b)
+      then c else raise Overflow
+
+    let ( / ) a b =
+      if a = min_int && b = -1 then raise Overflow else a / b
+
+    let ( ~- ) x =
+      if x <> min_int then -x else raise Overflow
+
+  end
-@call c:\overbld\ocaml\set-vars.bat
+@call c:\overbld\ocaml\set-vars.bat
 @bash run.sh
-EXT="byte"
-TARGETS="iteratees.$EXT tests_direct.$EXT"
-# bash
-rm -f $TARGETS && ocamlbuild iteratees.inferred.mli $TARGETS && \
-  (for X in $TARGETS;
-   do
-     echo "--------- $X: ---------"
-     ./$X
-   done
-   echo "------------------"
-  )
+EXT="byte"
+TARGETS="iteratees.$EXT tests_direct.$EXT"
+# bash
+rm -f $TARGETS && ocamlbuild iteratees.inferred.mli $TARGETS && \
+  (for X in $TARGETS;
+   do
+     echo "--------- $X: ---------"
+     ./$X
+   done
+   echo "------------------"
+  )
-open Tests_common;
-
-open Direct_IO;
-
-module T = Tests_functor(Direct_IO);
+open Tests_common;
+
+open Direct_IO;
+
+module T = Tests_functor(Direct_IO);
-(* +
-   The [place] type represents the place where exception
-   was raised.  For now, it's a name of IO function returned
-   an error.
-*)
-
-type place = string;
-
-
-(* +
-   IO exception, carrying the real IO exception and the place
-   (usually function name) where it was raised.
-*)
-
-exception EIO of (exn * place);
-
-
-(* +
-   Sometimes it's more convenient to have an IO result wrapped
-   in value with type [res 'a], than having to [IO.catch] errors.
-   See function [mres] in functor.
-*)
-
-type res +'a = [= `Ok of 'a | `Error of exn ]
-;
-
-
-(* +
-   This is a signature for IO monad.  These functions and types are used
-   by Iteratees functor.  It's possible that your implementation of IO
-   have much more functions than MonadIO, so you should not restrict
-   your IO implementation by this MonadIO signature.
-*)
-
-module type MonadIO
- =
-  sig
-    type m +'a;
-    value return : 'a -> m 'a;
-    value bind : ('a -> m 'b) -> m 'a -> m 'b;
-
-    value error : exn -> m 'a;
-    value catch : (unit -> m 'a) -> (exn -> m 'a) -> m 'a;
-
-    type output_channel;
-    value stdout : output_channel;
-    value write : output_channel -> string -> m unit;
-
-    type 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;
-       (* in lwt: read_into ic buffer offset length *)
-
-    value runIO : m 'a -> res 'a;
-  end
-;
+(* +
+   The [place] type represents the place where exception
+   was raised.  For now, it's a name of IO function returned
+   an error.
+*)
+
+type place = string;
+
+
+(* +
+   IO exception, carrying the real IO exception and the place
+   (usually function name) where it was raised.
+*)
+
+exception EIO of (exn * place);
+
+
+(* +
+   Sometimes it's more convenient to have an IO result wrapped
+   in value with type [res 'a], than having to [IO.catch] errors.
+   See function [mres] in functor.
+*)
+
+type res +'a = [= `Ok of 'a | `Error of exn ]
+;
+
+
+(* +
+   This is a signature for IO monad.  These functions and types are used
+   by Iteratees functor.  It's possible that your implementation of IO
+   have much more functions than MonadIO, so you should not restrict
+   your IO implementation by this MonadIO signature.
+*)
+
+module type MonadIO
+ =
+  sig
+    type m +'a;
+    value return : 'a -> m 'a;
+    value bind : ('a -> m 'b) -> m 'a -> m 'b;
+
+    value error : exn -> m 'a;
+    value catch : (unit -> m 'a) -> (exn -> m 'a) -> m 'a;
+
+    type output_channel;
+    value stdout : output_channel;
+    value write : output_channel -> string -> m unit;
+
+    type 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;
+       (* in lwt: read_into ic buffer offset length *)
+
+    value runIO : m 'a -> res 'a;
+  end
+;
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.