Ppxify cohttp

_oasis

@@ -28,9 +28,8 @@ Library cohttp
   Modules:       S, Code, Header, Cookie, Request, Response, Transfer,
                  Accept, Accept_parser, Accept_lexer, Accept_types, Link,
                  Auth, Header_io, Transfer_io, Connection, Body, String_io, Conf
-  BuildDepends:  re.emacs, stringext, uri (>= 1.5.0), uri.services,
-                 fieldslib (>= 109.20.00), pa_fields_conv,
-                 sexplib (>= 109.53.00), pa_sexp_conv,
+  BuildDepends:  re.emacs, stringext, uri (>= 1.5.0), uri.services, fieldslib,
+                 sexplib, ppx_fields_conv, ppx_sexp_conv,
                  bytes, base64 (>= 2.0.0)
   XMETARequires: re.emacs, stringext, uri, uri.services, fieldslib,
                  sexplib, bytes, base64
@@ -107,7 +106,7 @@ Library cohttp_lwt_xhr
   Path:          js
   Findlibname:   js
   FindlibParent: cohttp
-  BuildDepends:  cohttp.lwt-core, js_of_ocaml, js_of_ocaml.syntax
+  BuildDepends:  cohttp.lwt-core, js_of_ocaml, js_of_ocaml.ppx
   XMETARequires: cohttp.lwt-core, js_of_ocaml
   Modules:       Cohttp_lwt_xhr
 
@@ -388,7 +387,7 @@ Executable "test_xhr"
   Custom:             true
   CompiledObject:     byte
   Install:            false
-  BuildDepends:       cohttp, cohttp.js, js_of_ocaml.syntax
+  BuildDepends:       cohttp, cohttp.js, js_of_ocaml.ppx
 
 Executable "async-receive-post"
   Path:               examples/async

async/cohttp_async.ml

@@ -88,7 +88,7 @@ module Body = struct
     | B.t
     | `Pipe of string Pipe.Reader.t
   ]
-  with sexp_of
+  [@@deriving sexp_of]
 
   let empty = `Empty
   let of_string s = ((B.of_string s) :> t)
@@ -257,9 +257,9 @@ module Server = struct
 
   type ('address, 'listening_on) t = {
     server: ('address, 'listening_on) Tcp.Server.t sexp_opaque;
-  } with sexp_of
+  } [@@deriving sexp_of]
 
-  type response = Response.t * Body.t with sexp_of
+  type response = Response.t * Body.t [@@deriving sexp_of]
 
   let close t = Tcp.Server.close t.server
   let close_finished t = Tcp.Server.close_finished t.server

async/cohttp_async.mli

@@ -24,7 +24,7 @@ module Body : sig
   type t = [
     | Cohttp.Body.t
     | `Pipe of string Pipe.Reader.t
-  ] with sexp_of
+  ] [@@deriving sexp_of]
   include Cohttp.S.Body with type t := t
   val drain : t -> unit Deferred.t
   val is_empty : t -> bool Deferred.t
@@ -140,13 +140,13 @@ end
 
 module Server : sig
   type ('address, 'listening_on) t constraint 'address = [< Socket.Address.t ]
-  with sexp_of
+  [@@deriving sexp_of]
 
   val close          : (_, _) t -> unit Deferred.t
   val close_finished : (_, _) t -> unit Deferred.t
   val is_closed      : (_, _) t -> bool
 
-  type response = Response.t * Body.t with sexp_of
+  type response = Response.t * Body.t [@@deriving sexp_of]
 
   val respond :
     ?flush:bool ->

examples/async/s3_cp.ml

@@ -131,7 +131,7 @@ type region = [
   | `Us_east_1      (* US East (N. Virginia) *)
   | `Us_west_1      (* US West (N. California) *)
   | `Us_west_2      (* US West (Oregon) *)
-] with sexp
+] [@@deriving sexp]
 
 let region_of_string = function
   | "ap-northeast-1" -> `Ap_northeast_1
@@ -169,7 +169,7 @@ let region_host_string = function
 
 type service = [
   `S3
-] with sexp
+] [@@deriving sexp]
 
 let string_of_service = function
   | `S3 -> "s3"
@@ -284,7 +284,7 @@ module S3 = struct
     region : region;
     aws_access_key : string;
     aws_secret_key : string;
-  } with sexp
+  } [@@deriving sexp]
 
   let make_request ?body conf ~meth ~bucket ~objekt =
     let host_str = region_host_string conf.region in

js/cohttp_lwt_xhr.ml

@@ -31,18 +31,18 @@ module Body_builder(P : Params) = struct
 
   (* perform the body transfer in chunks. *)
   let chunked_body text =
-    let body_len = text##length in
+    let body_len = text##.length in
     let pos = ref 0 in
     let chunkerizer () =
       if !pos = body_len then
         Lwt.return C.Transfer.Done
       else
       if !pos + P.chunk_size >= body_len then begin
-        let str = text##substring_toEnd(!pos) in
+        let str = text##(substring_toEnd (!pos)) in
         pos := body_len;
         Lwt.return (C.Transfer.Final_chunk (P.convert_body_string str))
       end else begin
-        let str = text##substring(!pos, !pos+P.chunk_size) in
+        let str = text##(substring (!pos) (!pos+P.chunk_size)) in
         pos := !pos + P.chunk_size;
         Lwt.return (C.Transfer.Chunk (P.convert_body_string str))
       end
@@ -113,9 +113,9 @@ module Make_client_async(P : Params) = Make_api(struct
     let call ?headers ?body meth uri =
       let xml = XmlHttpRequest.create () in
       let (res : (Response.t Lwt.t * CLB.t) Lwt.t), wake = Lwt.task () in
-      let () = xml##_open(Js.string (C.Code.string_of_method meth),
-                          Js.string (Uri.to_string uri),
-                          Js._true) (* asynchronous call *)
+      let () = xml##(_open (Js.string (C.Code.string_of_method meth))
+                          (Js.string (Uri.to_string uri))
+                          (Js._true)) (* asynchronous call *)
       in
       (* set request headers *)
       let () =
@@ -127,25 +127,25 @@ module Make_client_async(P : Params) = Make_api(struct
                (* some headers lead to errors in the javascript console, should
                   we filter then out here? *)
                List.iter
-                 (fun v -> xml##setRequestHeader(Js.string k, Js.string v)) v)
+                 (fun v -> xml##(setRequestHeader (Js.string k) (Js.string v))) v)
             headers
       in
 
-      xml##onreadystatechange <-
+      xml##.onreadystatechange :=
         Js.wrap_callback
           (fun _ ->
-             match xml##readyState with
+             match xml##.readyState with
              | XmlHttpRequest.DONE -> begin
                  (* construct body *)
-                 let body = Bb.get xml##responseText in
+                 let body = Bb.get xml##.responseText in
                  (* (re-)construct the response *)
                  let response =
-                   let resp_headers = Js.to_string (xml##getAllResponseHeaders()) in
+                   let resp_headers = Js.to_string (xml##getAllResponseHeaders) in
                    let channel = C.String_io.open_in resp_headers in
                    Lwt.(Header_io.parse channel >|= fun resp_headers ->
                         Response.make
                           ~version:`HTTP_1_1
-                          ~status:(C.Code.status_of_code xml##status)
+                          ~status:(C.Code.status_of_code xml##.status)
                           ~flush:false (* ??? *)
                           ~encoding:(CLB.transfer_encoding body)
                           ~headers:resp_headers
@@ -161,12 +161,12 @@ module Make_client_async(P : Params) = Make_api(struct
 
       (* perform call *)
       (match body with
-       | None -> Lwt.return (xml##send(Js.null))
+       | None -> Lwt.return (xml##(send (Js.null)))
        | Some(body) ->
          CLB.to_string body >>= fun body ->
-         Lwt.return (xml##send(Js.Opt.return (Js.string body))))
+         Lwt.return (xml##(send (Js.Opt.return (Js.string body)))))
       >>= fun () ->
-      Lwt.on_cancel res (fun () -> xml##abort ());
+      Lwt.on_cancel res (fun () -> xml##abort);
 
       (* unwrap the response *)
       Lwt.(res >>= fun (r, b) -> r >>= fun r -> Lwt.return (r,b))
@@ -183,9 +183,9 @@ module Make_client_sync(P : Params) = Make_api(struct
 
     let call ?headers ?body meth uri =
       let xml = XmlHttpRequest.create () in
-      let () = xml##_open(Js.string (C.Code.string_of_method meth),
-                          Js.string (Uri.to_string uri),
-                          Js._false)  (* synchronous call *)
+      let () = xml##(_open (Js.string (C.Code.string_of_method meth))
+                          (Js.string (Uri.to_string uri))
+                          (Js._false))  (* synchronous call *)
       in
       (* set request headers *)
       let () =
@@ -197,27 +197,27 @@ module Make_client_sync(P : Params) = Make_api(struct
                           (* some headers lead to errors in the javascript console, should
                              we filter then out here? *)
                           (fun v ->
-                             xml##setRequestHeader(Js.string k, Js.string v)) v)
+                             xml##(setRequestHeader (Js.string k) (Js.string v))) v)
             headers
       in
       (* perform call *)
       (match body with
-       | None -> Lwt.return (xml##send(Js.null))
+       | None -> Lwt.return (xml##(send (Js.null)))
        | Some(body) ->
          CLB.to_string body >|= fun body ->
-         (xml##send(Js.Opt.return (Js.string body)))) >>= fun body ->
+         (xml##(send (Js.Opt.return (Js.string body))))) >>= fun body ->
 
   (* construct body *)
-  let body = Bb.get xml##responseText in
+  let body = Bb.get xml##.responseText in
 
   (* (re-)construct the response *)
-  let resp_headers = Js.to_string (xml##getAllResponseHeaders()) in
+  let resp_headers = Js.to_string (xml##getAllResponseHeaders) in
   Header_io.parse (C.String_io.open_in resp_headers)
   >>= fun resp_headers ->
 
   let response = Response.make
                    ~version:`HTTP_1_1
-                   ~status:(Cohttp.Code.status_of_code xml##status)
+                   ~status:(Cohttp.Code.status_of_code xml##.status)
                    ~flush:false
                    ~encoding:(CLB.transfer_encoding body)
                    ~headers:resp_headers

lib/accept.mli

@@ -20,10 +20,10 @@
 (** Qualities are integers between 0 and 1000.
     A header with ["q=0.7"] corresponds to a quality of [700].
 *)
-type q = int with sexp
+type q = int [@@deriving sexp]
 
 (** Lists, annotated with qualities. *)
-type 'a qlist = (q * 'a) list with sexp
+type 'a qlist = (q * 'a) list [@@deriving sexp]
 
 (** Sort by quality, biggest first.
     Respect the initial ordering.
@@ -32,19 +32,19 @@ val qsort : 'a qlist -> 'a qlist
 
 type pv = Accept_types.pv =
     T of string
-  | S of string with sexp
+  | S of string [@@deriving sexp]
 
-type p = string * pv with sexp
+type p = string * pv [@@deriving sexp]
 
 type media_range =
   Accept_types.media_range =
     MediaType of string * string
   | AnyMediaSubtype of string
-  | AnyMedia with sexp
+  | AnyMedia [@@deriving sexp]
 
 type charset = Accept_types.charset =
     Charset of string
-  | AnyCharset with sexp
+  | AnyCharset [@@deriving sexp]
 
 type encoding =
   Accept_types.encoding =
@@ -53,15 +53,15 @@ type encoding =
   | Compress
   | Deflate
   | Identity
-  | AnyEncoding with sexp
+  | AnyEncoding [@@deriving sexp]
 
 (** Basic language range tag.
     ["en-gb"] is represented as [Language ["en"; "gb"]].
     @see <https://tools.ietf.org/html/rfc7231#section-5.3.5> the specification.
 *)
 type language = Accept_types.language =
     Language of string list
-  | AnyLanguage with sexp
+  | AnyLanguage [@@deriving sexp]
 
 
 val media_ranges :

lib/accept_types.ml

@@ -19,24 +19,24 @@
 
 open Sexplib.Std
 
-type pv = T of string | S of string with sexp
-type p = string * pv with sexp
+type pv = T of string | S of string [@@deriving sexp]
+type p = string * pv [@@deriving sexp]
 type media_range =
   | MediaType of string * string
   | AnyMediaSubtype of string
-  | AnyMedia with sexp
+  | AnyMedia [@@deriving sexp]
 type charset =
   | Charset of string
-  | AnyCharset with sexp
+  | AnyCharset [@@deriving sexp]
 type encoding =
   | Encoding of string
   | Gzip
   | Compress
   | Deflate
   | Identity
-  | AnyEncoding with sexp
+  | AnyEncoding [@@deriving sexp]
 type language =
   | Language of string list
-  | AnyLanguage with sexp
-type q = int with sexp
-type 'a qlist = (q * 'a) list with sexp
+  | AnyLanguage [@@deriving sexp]
+type q = int [@@deriving sexp]
+type 'a qlist = (q * 'a) list [@@deriving sexp]

lib/auth.ml

@@ -19,12 +19,12 @@ open Printf
 
 type challenge = [
  | `Basic of string (* realm *)
-] with sexp
+] [@@deriving sexp]
 
 type credential = [
  | `Basic of string * string (* username, password *)
  | `Other of string
-]  with sexp
+]  [@@deriving sexp]
 
 let string_of_credential (cred:credential) =
   match cred with

lib/auth.mli

@@ -19,7 +19,7 @@
 (** HTTP authentication challenge types *)
 type challenge = [
  | `Basic of string (** Basic authentication within a realm *)
-] with sexp
+] [@@deriving sexp]
 
 (** HTTP authorization credential types *)
 type credential = [
@@ -28,7 +28,7 @@ type credential = [
   | `Other of string
   (** An unknown credential type that will be passed straight through
       to the application layer *)
-] with sexp
+] [@@deriving sexp]
 
 (** [string_of_credential] converts the {!credential} to a string compatible
     with the HTTP/1.1 wire format for authorization credentials ("responses") *)

lib/body.ml

@@ -20,7 +20,7 @@ type t = [
   | `Empty
   | `String of string
   | `Strings of string list
-] with sexp
+] [@@deriving sexp]
 
 let empty = `Empty
 

lib/body.mli

@@ -22,7 +22,7 @@ type t = [
   | `Empty
   | `String of string
   | `Strings of string list
-] with sexp
+] [@@deriving sexp]
 
 (** Signature for the core of HTTP body handling.  Implementations
     will extend this signature to add more functions for streaming