demo about generating types and CPS

test.ml

open Ppxlib
let id x = x
let loc = Location.none

open Ast_builder.Default
let arrow1 = ptyp_arrow ~loc Nolabel
let arrow2 = pcty_arrow ~loc Nolabel

class  c1 = object(self : 'self)
  method fa1 : string -> ((core_type -> 'r) -> core_type -> 'r)  -> (core_type -> 'r) =
    fun name k ->
      k @@ (fun arg -> arrow1 [%type: [%t ptyp_var ~loc name]  -> string] arg)

  method fa2 (* : string -> ((core_type -> 'r) -> core_type -> 'r)  -> (core_type -> 'r) *) =
    fun name k ->
      k @@ (fun arg -> arrow2 [%type: [%t ptyp_var ~loc name]  -> string] arg)

  method fa : 'a . (Ppxlib.core_type -> 'a -> 'a) ->
         string -> (('a -> 'a) -> 'a -> 'a) -> 'a -> 'a =
    fun chain name k ->
      k @@ (fun arg -> chain [%type: [%t ptyp_var ~loc name]  -> string] arg)

  method make1 xs tail : core_type =
    List.fold_left
      (fun  acc name -> self#fa1 name (fun f -> fun arg -> acc @@ f arg))
      id
      xs
      tail

  method make2 xs tail : class_type =
    List.fold_left
      (fun  acc name -> self#fa2 name (fun f -> fun arg -> acc @@ f arg))
      id
      xs
      tail

  method make: 'b . (Ppxlib.core_type -> 'b -> 'b) -> string list -> 'b -> 'b =
    fun chain xs tail ->
    List.fold_left
      (fun  acc name -> self#fa chain name (fun f -> fun arg -> acc @@ f arg))
      id
      xs
      tail

end


class ['self] c2 = object(self : 'self)
  inherit c1  as super
  (* method! fa chain name k =
   *   k @@
   *   super#fa chain name (fun f arg -> chain [%type: string] (f arg) ) *)
  method! fa chain name k =
    k @@
    super#fa chain name (fun f arg -> f @@ chain [%type: string]  arg )

end

let tail1 = [%type: tail]
let tail2 = pcty_signature ~loc @@ class_signature ~self:(ptyp_any ~loc) ~fields:[]

let wrap o =
  Pprintast.core_type  Format.std_formatter (o#make1 ["a"; "b"] tail1);
  Format.printf "\n%!";
  Pprintast.class_type Format.std_formatter (o#make2 ["a"; "b"] tail2);
  Format.printf "\n%!"

let wrap2 p chain tail o =
  p Format.std_formatter (o#make chain ["a"; "b"] tail);
  Format.printf "\n%!"


let () =
  (* wrap (new c1);
   * wrap (new c2); *)
  (* wrap2   Pprintast.core_type  arrow1 tail1 (new c1);
   * wrap2   Pprintast.class_type arrow2 tail2 (new c2) *)

  Pprintast.core_type  Format.std_formatter ((new c1)#make arrow1 ["a"; "b"] tail1);
  Format.printf "\n%!";
  Pprintast.class_type  Format.std_formatter ((new c1)#make arrow2 ["a"; "b"] tail2);
  Format.printf "\n%!";

  Pprintast.core_type  Format.std_formatter ((new c2)#make arrow1 ["a"; "b"] tail1);
  Format.printf "\n%!";
  Pprintast.class_type Format.std_formatter ((new c2)#make arrow2 ["a"; "b"] tail2);
  Format.printf "\n%!"