Source file expander.ml

(*
 * Generic Transformers PPX syntax extension.
 * Copyright (C) 2016-2021
 *   Dmitrii Kosarev aka Kakadu
 * St.Petersburg State University, JetBrains Research
 *)

open Base
open Ppxlib
open Ppxlib.Ast_builder.Default
open HelpersBase
open Printf
open Naming

let ( @@ ) = Caml.( @@ )

type config_plugin =
  | Skip
  | Use of Plugin_intf.plugin_args

type config =
  { mutable registered_plugins : (string * (module Plugin_intf.MAKE)) list
  ; mutable inline_callback : string -> (module Plugin_intf.MAKE) -> unit
  }

let config = { registered_plugins = []; inline_callback = (fun _ _ -> ()) }
let get_registered_plugins () = List.map ~f:fst config.registered_plugins

let register_plugin name m =
  config.registered_plugins <- (name, m) :: config.registered_plugins;
  config.inline_callback name m
;;

let set_inline_registration f =
  config.inline_callback <- f;
  List.iter config.registered_plugins ~f:(fun (name, m) -> f name m)
;;

let register_ppx_inline_plugin _ _ = ()

module Make (AstHelpers : GTHELPERS_sig.S) = struct
  open AstHelpers

  let prepare_patt_match ~loc ?else_case what constructors make_rhs =
    let on_alg cdts =
      let k cs = Exp.match_ ~loc what cs in
      k
      @@ List.map cdts ~f:(fun cd ->
             match cd.pcd_args with
             | Pcstr_record ls ->
               let names = List.map ls ~f:(fun _ -> gen_symbol ()) in
               case
                 ~lhs:
                   (Pat.constr_record ~loc cd.pcd_name.txt
                   @@ List.map2_exn ls names ~f:(fun l s ->
                          l.pld_name.txt, Pat.var ~loc s))
                 ~rhs:(make_rhs cd names)
             | Pcstr_tuple args ->
               let names = List.map args ~f:(fun _ -> gen_symbol ()) in
               (* notify "constructing %s of %s" cd.pcd_name.txt (String.concat ~sep:" " names); *)
               case
                 ~lhs:(Pat.constr ~loc cd.pcd_name.txt @@ List.map ~f:(Pat.var ~loc) names)
                 ~rhs:(make_rhs cd names))
      @
      match else_case with
      | None -> []
      | Some f ->
        let name = gen_symbol ~prefix:"else" () in
        [ case ~lhs:(Pat.sprintf ~loc "%s" name) ~rhs:(f name) ]
    in
    let on_poly cs = assert false in
    match constructors with
    | `Algebraic cdts -> on_alg cdts
    | `PolyVar cs -> on_poly cs
  ;;

  let prepare_patt_match_poly ~loc what rows labels ~onrow ~onlabel ~oninherit =
    let k cs = Exp.match_ ~loc what cs in
    let rs =
      List.map rows ~f:(function
          | Rtag (lab, _, args) ->
            let args =
              match args with
              | [ t ] -> unfold_tuple t
              | [] -> []
              | _ -> failwith "we don't support conjunction types"
            in
            let names = List.map args ~f:(fun _ -> gen_symbol ~prefix:"_" ()) in
            let lhs =
              Pat.variant ~loc lab.txt @@ List.map ~f:(fun s -> Pat.var ~loc s) names
            in
            case ~lhs ~rhs:(onrow lab @@ List.zip_exn names args)
          | Rinherit typ ->
            (match typ.ptyp_desc with
            | Ptyp_constr ({ txt; _ }, ts) ->
              let newname = "subj" in
              let lhs = Pat.alias ~loc (Pat.type_ ~loc txt) newname in
              case ~lhs ~rhs:(oninherit ts txt newname)
            | _ -> failwith "this inherit field isn't supported"))
    in
    let ls =
      match labels with
      | None -> []
      | Some ls ->
        List.map ls ~f:(fun lab ->
            let newname = "subj" in
            let lhs = Pat.alias ~loc (Pat.type_ ~loc (Lident lab)) newname in
            case ~lhs ~rhs:(onlabel lab newname))
    in
    k @@ rs @ ls
  ;;

  let params_of_interface_class ~loc params =
    (* actual params depend on sort of type.
     2 + 3*params_count + 1 (for polyvar subtyping)
  *)
    (List.concat
    @@ map_type_param_names params ~f:(fun s ->
           [ named_type_arg ~loc ("i" ^ s)
           ; named_type_arg ~loc s
           ; named_type_arg ~loc ("s" ^ s)
           ]))
    @ [ named_type_arg ~loc "inh"
      ; named_type_arg ~loc Naming.extra_param_name
      ; named_type_arg ~loc "syn"
      ]
  ;;

  let make_interface_class_sig ~loc tdecl =
    let name = tdecl.ptype_name in
    let k fields =
      [ Sig.class_
          ~loc
          ~virt:true
          ~name:(class_name_for_typ name.txt)
          ~params:(params_of_interface_class ~loc tdecl.ptype_params)
          fields
      ]
    in
    let on_constructor cd =
      let methname = Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt in
      let typs =
        match cd.pcd_args with
        | Pcstr_record ls -> List.map ls ~f:(fun x -> x.pld_type)
        | Pcstr_tuple ts -> ts
      in
      Ctf.method_ ~loc methname ~virt:true
      @@ Typ.chain_arrow ~loc
      @@ [ Typ.var ~loc "inh"; Typ.var ~loc "extra" ]
      @ List.map typs ~f:Typ.from_caml
      @ [ Typ.var ~loc "syn" ]
    in
    visit_typedecl
      ~loc
      tdecl
      ~onrecord:(fun _labels ->
        (* almost the same as plugin#get_class_sig*)
        k
          [ (Ctf.method_ ~loc (Naming.meth_name_for_record tdecl) ~virt:true
            @@ Typ.chain_arrow ~loc
            @@
            let open Typ in
            [ var ~loc "inh"; use_tdecl tdecl; var ~loc "syn" ])
          ])
      ~onabstract:(fun () ->
        (* For purely abstract type we can only generate interface
           (we don't know methods)  *)
        [])
      ~onvariant:(fun cds -> k @@ List.map cds ~f:on_constructor)
      ~onmanifest:(fun typ ->
        let wrap name params =
          let inh_params =
            List.concat_map params ~f:(fun typ ->
                [ map_core_type typ ~onvar:(fun n ->
                      Some (ptyp_var ~loc:typ.ptyp_loc ("i" ^ n)))
                ; typ
                ; map_core_type typ ~onvar:(fun n ->
                      Some (ptyp_var ~loc:typ.ptyp_loc ("s" ^ n)))
                ])
            |> List.map ~f:Typ.from_caml
          in
          let inh_params =
            inh_params
            @ [ Typ.var ~loc "inh"
              ; Typ.var ~loc Naming.extra_param_name
              ; Typ.var ~loc "syn"
              ]
          in
          [ Ctf.inherit_ ~loc
            @@ Cty.constr ~loc (map_longident ~f:class_name_for_typ name) inh_params
          ]
        in
        let rec helper typ =
          match typ.ptyp_desc with
          | Ptyp_constr ({ txt; loc }, params) ->
            (* a type alias on toplevel *)
            k @@ wrap txt params
          | Ptyp_var name ->
            let new_lident = Ldot (Lident "GT", "free") in
            let open Ppxlib.Ast_builder.Default in
            let loc = typ.ptyp_loc in
            helper @@ ptyp_constr ~loc (Located.mk ~loc new_lident) [ ptyp_var ~loc name ]
          | Ptyp_tuple ts ->
            (* let's say we have predefined aliases for now *)
            let new_lident = Ldot (Lident "GT", sprintf "tuple%d" @@ List.length ts) in
            let open Ppxlib.Ast_builder.Default in
            let loc = typ.ptyp_loc in
            helper @@ ptyp_constr ~loc (Located.mk ~loc new_lident) ts
          | Ptyp_alias (typ, new_name) ->
            let loc = typ.ptyp_loc in
            map_core_type typ ~onvar:(fun as_ ->
                let params = List.map ~f:fst tdecl.ptype_params in
                let open Ppxlib.Ast_builder.Default in
                if String.equal as_ new_name
                then Some (ptyp_constr ~loc (Located.lident ~loc name.txt) params)
                else Some (ptyp_var ~loc as_))
            |> helper
          | Ptyp_variant (rows, _, labels) ->
            (* rows go to virtual methods. label goes to inherit fields *)
            let meths =
              List.concat_map rows ~f:(fun rf ->
                  match rf.prf_desc with
                  | Rtag (lab, _, args) ->
                    let args =
                      match args with
                      | [] -> []
                      | [ { ptyp_desc = Ptyp_tuple ts; _ } ] -> ts
                      | [ t ] -> [ t ]
                      | _ -> failwith "conjective not supported"
                    in
                    let methname = Naming.meth_of_constr lab.txt in
                    let ts =
                      let open Typ in
                      [ var ~loc "inh"; var ~loc "extra" ]
                      @ List.map ~f:from_caml args
                      @ [ var ~loc "syn" ]
                      |> chain_arrow ~loc
                    in
                    [ Ctf.method_ ~loc ~virt:true methname ts ]
                  | Rinherit typ ->
                    (match typ.ptyp_desc with
                    | Ptyp_constr ({ txt; loc }, params) -> wrap txt params
                    | _ -> assert false))
            in
            k meths
          | Ptyp_extension _ ->
            not_implemented
              "extensions in types not implemented: %s"
              (string_of_core_type typ)
          | _ -> failwith " not implemented"
        in
        let toplevel typ =
          match typ.ptyp_desc with
          | Ptyp_tuple _ | Ptyp_var _ ->
            k
            @@ [ on_constructor
                 @@ Ppxlib.Ast_builder.Default.constructor_declaration
                      ~loc:typ.ptyp_loc
                      ~name:(Located.map String.uppercase tdecl.ptype_name)
                      ~args:(Pcstr_tuple [])
                      ~res:None
               ]
          | _ -> helper typ
        in
        toplevel typ)
  ;;

  let inherit_iface_class ~loc name params =
    let inh_params =
      List.concat_map params ~f:(fun typ ->
          [ map_core_type typ ~onvar:(fun n ->
                Some (ptyp_var ~loc:typ.ptyp_loc ("i" ^ n)))
          ; typ
          ; map_core_type typ ~onvar:(fun n ->
                Some (ptyp_var ~loc:typ.ptyp_loc ("s" ^ n)))
          ])
      |> List.map ~f:Typ.from_caml
    in
    let inh_params =
      inh_params @ [ Typ.var ~loc "inh"; Typ.var ~loc "extra"; Typ.var ~loc "syn" ]
    in
    Cf.inherit_ ~loc
    @@ Cl.constr ~loc (map_longident ~f:class_name_for_typ name) inh_params
  ;;

  let make_interface_class ~loc tdecl =
    let params = List.map ~f:fst tdecl.ptype_params in
    let name = tdecl.ptype_name in
    let ans ?(is_poly = false) fields =
      class_declaration
        ~loc
        ~name:(class_name_for_typ name.txt)
        fields
        ~virt:true
        ~params:(params_of_interface_class ~loc tdecl.ptype_params)
    in
    let on_constructor cd =
      let methname = Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt in
      let typs =
        match cd.pcd_args with
        | Pcstr_record ls -> List.map ls ~f:(fun x -> x.pld_type)
        | Pcstr_tuple ts -> ts
      in
      Cf.method_virtual ~loc methname
      @@ Typ.(
           List.fold_right typs ~init:(var ~loc "syn") ~f:(fun t ->
               arrow ~loc (from_caml t))
           |> arrow ~loc (var ~loc "extra")
           |> arrow ~loc (var ~loc "inh"))
    in
    visit_typedecl
      ~loc
      tdecl
      ~onopen:(fun () -> ans [])
      ~onrecord:(fun _ ->
        ans
          [ (Cf.method_virtual ~loc (sprintf "do_%s" tdecl.ptype_name.txt)
            @@ Typ.(
                 arrow ~loc (var ~loc "inh")
                 @@ arrow ~loc (use_tdecl tdecl) (var ~loc "syn")))
          ])
      ~onvariant:(fun cds -> ans @@ List.map cds ~f:on_constructor)
      ~onmanifest:(fun typ ->
        let wrap ?(is_poly = false) name params =
          [ inherit_iface_class ~loc name params ]
        in
        let rec helper typ =
          match typ with
          | _ ->
            (match typ.ptyp_desc with
            | Ptyp_var name ->
              let new_lident = Ldot (Lident "GT", "free") in
              let open Ppxlib.Ast_builder.Default in
              let loc = typ.ptyp_loc in
              helper
              @@ ptyp_constr ~loc (Located.mk ~loc new_lident) [ ptyp_var ~loc name ]
            | Ptyp_constr ({ txt; loc }, params) ->
              (* a type alias on toplevel *)
              ans @@ wrap txt params
            | Ptyp_tuple ts ->
              (* let's say we have predefined aliases for now *)
              let new_lident = Ldot (Lident "GT", sprintf "tuple%d" @@ List.length ts) in
              let open Ppxlib.Ast_builder.Default in
              let loc = typ.ptyp_loc in
              helper @@ ptyp_constr ~loc (Located.mk ~loc new_lident) ts
            | Ptyp_alias (typ, new_name) ->
              let loc = typ.ptyp_loc in
              map_core_type typ ~onvar:(fun as_ ->
                  let open Ppxlib.Ast_builder.Default in
                  if String.equal as_ new_name
                  then Some (ptyp_constr ~loc (Located.lident ~loc name.txt) params)
                  else Some (ptyp_var ~loc as_))
              |> helper
            | Ptyp_variant (rows, _, labels) ->
              (* rows go to virtual methods. label goes to inherit fields *)
              ans ~is_poly:true
              @@ List.concat_map rows ~f:(fun rf ->
                     match rf.prf_desc with
                     | Rtag (lab, _, []) ->
                       let methname = sprintf "c_%s" lab.txt in
                       [ (Cf.method_virtual ~loc methname
                         @@ Typ.(
                              var ~loc "syn"
                              |> arrow ~loc @@ var ~loc "extra"
                              |> arrow ~loc (var ~loc "inh")))
                       ]
                     | Rtag (lab, _, [ typ ]) ->
                       (* print_endline "HERE"; *)
                       let args =
                         match typ.ptyp_desc with
                         | Ptyp_tuple ts -> ts
                         | _ -> [ typ ]
                       in
                       let methname = sprintf "c_%s" lab.txt in
                       [ (Cf.method_virtual ~loc methname
                         @@
                         let open Typ in
                         List.fold_right args ~init:(var ~loc "syn") ~f:(fun t ->
                             arrow ~loc (from_caml t))
                         |> arrow ~loc @@ var ~loc "extra"
                         |> arrow ~loc (var ~loc "inh"))
                       ]
                     | Rtag (_, _, _) -> failwith "Can't deal with conjunctive types"
                     | Rinherit typ ->
                       (match typ.ptyp_desc with
                       | Ptyp_constr ({ txt; loc }, params) ->
                         wrap ~is_poly:true txt params
                       | _ -> assert false))
            | Ptyp_extension _ ->
              not_implemented "extensions in types `%s`" (string_of_core_type typ)
            | _ -> failwith "not implemented ")
        in
        let toplevel typ =
          match typ.ptyp_desc with
          | Ptyp_tuple _ | Ptyp_var _ ->
            ans
            @@ [ on_constructor
                 @@ Ppxlib.Ast_builder.Default.constructor_declaration
                      ~loc:typ.ptyp_loc
                      ~name:(Located.map String.uppercase tdecl.ptype_name)
                      ~args:(Pcstr_tuple [])
                      ~res:None
               ]
          | _ -> helper typ
        in
        toplevel typ)
  ;;

  let wildcard_tdecl td =
    let loc = loc_from_caml td.ptype_loc in
    Typ.constr ~loc (Lident td.ptype_name.txt)
    @@ List.map td.ptype_params ~f:(fun _ -> Typ.any ~loc)
  ;;

  let make_gcata_typ ~loc tdecl =
    let on_alias_or_abstract () =
      let args =
        map_type_param_names tdecl.ptype_params ~f:(fun name ->
            [ Typ.any ~loc; Typ.var ~loc name; Typ.var ~loc @@ "s" ^ name ])
        |> List.concat
      in
      let args = args @ [ Typ.var ~loc "inh"; Typ.use_tdecl tdecl; Typ.var ~loc "syn" ] in
      Typ.class_ ~loc (Lident (class_name_for_typ tdecl.ptype_name.txt)) args
    in
    let tr_t =
      visit_typedecl
        ~loc
        tdecl
        ~onabstract:(fun () -> on_alias_or_abstract ())
        ~onrecord:(fun _ ->
          Typ.object_ ~loc Open
          @@ [ ( sprintf "do_%s" tdecl.ptype_name.txt
               , Typ.(
                   chain_arrow ~loc [ var ~loc "inh"; use_tdecl tdecl; var ~loc "syn" ])
               )
             ])
        ~onvariant:(fun cds ->
          Typ.object_ ~loc Open
          @@ List.map cds ~f:(fun cd ->
                 let typs =
                   match cd.pcd_args with
                   | Pcstr_record ls -> List.map ls ~f:(fun x -> x.pld_type)
                   | Pcstr_tuple ts -> ts
                 in
                 let new_ts =
                   let open Typ in
                   [ var ~loc "inh"; use_tdecl tdecl ]
                   @ List.map typs ~f:Typ.from_caml
                   @ [ Typ.var ~loc "syn" ]
                 in
                 ( Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt
                 , Typ.chain_arrow ~loc new_ts )))
        ~onmanifest:(fun t ->
          let rec helper typ =
            match typ.ptyp_desc with
            | Ptyp_constr (_, _) -> on_alias_or_abstract ()
            | Ptyp_var name ->
              let new_lident = Ldot (Lident "GT", "free") in
              let open Ppxlib.Ast_builder.Default in
              let loc = typ.ptyp_loc in
              helper
              @@ ptyp_constr ~loc (Located.mk ~loc new_lident) [ ptyp_var ~loc name ]
            | Ptyp_variant (rows, _flg, _) ->
              let params =
                map_type_param_names tdecl.ptype_params ~f:(fun s ->
                    [ Typ.any ~loc; Typ.var ~loc s; Typ.var ~loc @@ "s" ^ s ])
              in
              Typ.class_
                ~loc
                (Lident (class_name_for_typ tdecl.ptype_name.txt))
                (List.concat params
                @ Typ.
                    [ var ~loc "inh"
                    ; openize_poly ~loc
                      @@ Typ.constr ~loc (Lident tdecl.ptype_name.txt)
                      @@ map_type_param_names tdecl.ptype_params ~f:(Typ.var ~loc)
                    ; var ~loc "syn"
                    ])
            | Ptyp_tuple ts -> helper @@ constr_of_tuple ~loc:t.ptyp_loc ts
            | _ -> failwith "Unsupported case during generate of the type of gcata"
          in
          helper t)
    in
    let subj_t = Typ.use_tdecl tdecl in
    Typ.(chain_arrow ~loc [ tr_t; var ~loc "inh"; subj_t; var ~loc "syn" ])
  ;;

  let make_gcata_sig ~loc ?(shortname = false) tdecl =
    let wrap () =
      let type_ = make_gcata_typ ~loc tdecl in
      let name =
        if shortname then "gcata" else Printf.sprintf "gcata_%s" tdecl.ptype_name.txt
      in
      [ Sig.value ~loc ~name type_ ]
    in
    visit_typedecl
      ~loc
      tdecl
      ~onrecord:(fun _ -> wrap ())
      ~onvariant:(fun _ -> wrap ())
      ~onmanifest:(fun _ -> wrap ())
      ~onabstract:(fun () -> [])
  ;;

  let make_gcata_str ~loc tdecl =
    let gcata_pat = Pat.var ~loc (sprintf "gcata_%s" tdecl.ptype_name.txt) in
    let ans k =
      let tr =
        let wrap t = if is_polyvariant_tdecl tdecl then openize_poly ~loc t else t in
        Pat.constraint_ ~loc (Pat.var ~loc "tr")
        @@ Typ.class_
             ~loc
             (Lident (Naming.class_name_for_typ tdecl.ptype_name.txt))
             (let param_names =
                List.mapi tdecl.ptype_params ~f:(fun i _ ->
                    gen_symbol ~prefix:(sprintf "typ%d" i) ())
              in
              let typ_self =
                Typ.constr ~loc (Lident tdecl.ptype_name.txt)
                @@ List.map param_names ~f:(Typ.var ~loc)
              in
              List.concat_map param_names ~f:(fun name ->
                  Typ.[ any ~loc; var ~loc name; any ~loc ])
              @ [ Typ.any ~loc; wrap @@ typ_self; Typ.any ~loc ])
      in
      Str.single_value
        ~loc
        gcata_pat
        (Exp.fun_list ~loc Pat.[ tr; var ~loc "inh"; var ~loc "subj" ] k)
    in
    let match_and_openize ~loc ident type_lident =
      let new_name = "foo" in
      Exp.match_
        ~loc
        ident
        [ case
            ~lhs:(Pat.alias ~loc (Pat.type_ ~loc type_lident) new_name)
            ~rhs:(Exp.ident ~loc new_name)
        ]
    in
    let onvariant cds =
      ans
      @@ prepare_patt_match ~loc (Exp.ident ~loc "subj") (`Algebraic cds) (fun cd names ->
             (* TODO: Subj ident has to be passed as an argument *)
             let subj = "subj" in
             List.fold_left
               ("inh" :: subj :: names)
               ~init:
                 (Exp.send
                    ~loc
                    (Exp.ident ~loc "tr")
                    (Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt))
               ~f:(fun acc arg -> Exp.app ~loc acc (Exp.ident ~loc arg)))
    in
    visit_typedecl
      ~loc
      tdecl
      ~onopen:(fun () -> ans @@ Exp.failwith_ ~loc "Extensible types not yet supported")
      ~onrecord:(fun _labels ->
        let methname = sprintf "do_%s" tdecl.ptype_name.txt in
        ans
        @@ Exp.(
             app_list
               ~loc
               (send ~loc (ident ~loc "tr") methname)
               [ ident ~loc "inh"; ident ~loc "subj" ]))
      ~onmanifest:(fun typ ->
        let rec helper t =
          match t.ptyp_desc with
          | Ptyp_alias (t, _) -> helper t
          | Ptyp_var name ->
            let new_lident = Ldot (Lident "GT", "free") in
            let open Ppxlib.Ast_builder.Default in
            let loc = typ.ptyp_loc in
            helper @@ ptyp_constr ~loc (Located.mk ~loc new_lident) [ ptyp_var ~loc name ]
          | Ptyp_constr ({ txt }, _) ->
            Str.single_value
              ~loc
              gcata_pat
              (Exp.of_longident ~loc @@ map_longident txt ~f:Naming.gcata_name_for_typ)
          | Ptyp_tuple ts ->
            (* let's say we have predefined aliases for now *)
            helper @@ constr_of_tuple ~loc:t.ptyp_loc ts
          | Ptyp_variant (rows, _, maybe_labels) ->
            let subj_s = "subj" in
            ans
            @@ prepare_patt_match_poly
                 ~loc
                 (Exp.ident ~loc subj_s)
                 (List.map rows ~f:(fun { prf_desc } -> prf_desc))
                 maybe_labels
                 ~onrow:(fun cname names ->
                   List.fold_left
                     ~init:(Exp.send ~loc (Exp.ident ~loc "tr") ("c_" ^ cname.txt))
                     ~f:(Exp.app ~loc)
                     (Exp.ident ~loc "inh"
                     :: match_and_openize
                          ~loc
                          (Exp.ident ~loc subj_s)
                          (Lident tdecl.ptype_name.txt)
                     :: List.map ~f:(fun (s, _) -> Exp.ident ~loc s) names))
                 ~onlabel:(fun label patname -> failwith "not implemented")
                 ~oninherit:(fun params cident patname ->
                   Exp.app_list
                     ~loc
                     (Exp.of_longident ~loc @@ map_longident cident ~f:gcata_name_for_typ)
                     (List.map [ "tr"; "inh"; patname ] ~f:(Exp.sprintf ~loc "%s")))
          | Ptyp_object (_, _) -> failwith "not implemented: object types"
          | Ptyp_class (_, _) -> failwith "not implemented: class types"
          | Ptyp_package _ -> failwith "not implemented: package types"
          | Ptyp_extension _ -> failwith "not implemented: extension types"
          | Ptyp_arrow _ -> failwith "not implemented: arrow types"
          | Ptyp_any ->
            failwith "not implemented: wildcard types (but it should be easy to rewrite)"
          | Ptyp_poly (_, _) -> failwith "not implemented: existential types"
        in
        let toplevel t =
          match t.ptyp_desc with
          | Ptyp_var _ | Ptyp_tuple _ ->
            ans
            @@ Exp.app_list
                 ~loc
                 (Exp.send
                    ~loc
                    (Exp.ident ~loc "tr")
                    (Naming.meth_of_constr (String.uppercase tdecl.ptype_name.txt)))
                 (List.map ~f:(Exp.ident ~loc) [ "inh"; "subj" ])
          | _ -> helper t
        in
        toplevel typ)
      ~onvariant
  ;;

  (* create opened renaming for polymorphic variant *)
  (* seems that we don't need it no more *)
  let make_heading_gen ~loc wrap tdecl = []

  let collect_plugins_str ~loc tdecl all_tdecls plugins : Str.t list =
    let wrap p tdecl =
      p#eta_and_exp
        ~center:(Exp.sprintf ~loc "%s_%s" p#trait_name tdecl.ptype_name.txt)
        tdecl
    in
    let plugin_fields =
      List.map plugins ~f:(fun p ->
          Cf.method_concrete ~loc p#trait_name
          @@
          if p#need_inh_attr
          then
            Exp.sprintf ~loc "%s" @@ Naming.trf_function p#trait_name tdecl.ptype_name.txt
          else wrap p tdecl)
    in
    let tname = tdecl.ptype_name.txt in
    (* The pack itself *)
    let gcata_ident = Exp.sprintf ~loc "gcata_%s" tname in
    (Str.single_value ~loc (Pat.sprintf ~loc "%s" tname)
    @@ Exp.record
         ~loc
         [ Ldot (lident "GT", "gcata"), gcata_ident
         ; ( Ldot (lident "GT", "fix")
           , if List.length all_tdecls > 1
             then Exp.sprintf ~loc "%s" @@ Naming.make_fix_name all_tdecls
             else
               Exp.fun_ ~loc (Pat.var ~loc "eta")
               @@ Exp.app_list
                    ~loc
                    (Exp.of_longident ~loc (Ldot (Lident "GT", "transform_gc")))
                    [ gcata_ident; Exp.sprintf ~loc "eta" ] )
         ; ( Ldot (lident "GT", "plugins")
           , Exp.object_ ~loc
             @@ class_structure ~self:(Pat.any ~loc) ~fields:plugin_fields )
         ])
    :: List.filter_map plugins ~f:(fun p ->
           (* also we generate transformation function with unit preapplied
         Because we seems to need them in case of abstract type in the interface
      *)
           if p#need_inh_attr
           then None
           else (
             let fname = Naming.trf_function p#trait_name tdecl.ptype_name.txt in
             Option.some
             @@ Str.single_value ~loc (Pat.sprintf ~loc "%s" fname) (wrap p tdecl)))
  ;;

  let rename_params tdecl =
    let loc = tdecl.ptype_loc in
    visit_typedecl
      ~loc
      tdecl
      ~onmanifest:(fun typ ->
        let names = map_type_param_names tdecl.ptype_params ~f:id in
        let r_names, new_manifest =
          List.fold_left ~init:([], typ) names ~f:(fun (ns, acc) name ->
              if String.equal name Naming.self_typ_param_name
              then (
                let n_new = Naming.self_typ_param_name ^ "__new" in
                let t2 =
                  map_core_type acc ~onvar:(fun s ->
                      (* Caml.Printf.printf "cmp '%s' and '%s' = %b\n%!" s name (String.equal s name ); *)
                      if String.equal s name then Some (ptyp_var ~loc n_new) else None)
                in
                n_new :: ns, t2)
              else name :: ns, acc)
        in
        { tdecl with
          ptype_params =
            List.map2_exn tdecl.ptype_params (List.rev r_names) ~f:(fun (_, v) s ->
                ptyp_var ~loc s, v)
        ; ptype_manifest = Some new_manifest
        })
      ~onvariant:(fun _ -> tdecl)
      ~onabstract:(fun _ -> tdecl)
      ~onrecord:(fun _ -> tdecl)
  ;;

  (* TODO: Implement general case about renaming of paramters *)

  module G = Graph.Persistent.Digraph.Concrete (String)
  module T = Graph.Topological.Make (G)
  module SM = Caml.Map.Make (String)

  let topsort_tdecls tdecls =
    (* TODO: we need topological sorting because in case
     *   type y = int x
     *   type 'a x = ....
     * we need to declare class for x before class for y
     * due to inheritance
     *)
    let name_map =
      List.fold_left ~init:SM.empty tdecls ~f:(fun acc tdecl ->
          match tdecl with
          | { ptype_name } -> SM.add ptype_name.txt tdecl acc)
    in
    let g =
      List.fold_left ~init:G.empty tdecls ~f:(fun acc tdecl ->
          let acc = G.add_vertex acc tdecl.ptype_name.txt in
          let info =
            visit_typedecl
              ~loc:tdecl.ptype_loc
              tdecl
              ~onrecord:(fun _ -> None)
              ~onvariant:(fun _ -> None)
              ~onabstract:(fun _ -> None)
              ~onopen:(fun _ -> None)
              ~onmanifest:(fun typ ->
                match typ.ptyp_desc with
                | Ptyp_constr ({ txt = Lident s }, _) -> Some s
                | _ -> None)
          in
          match info with
          | None -> acc
          | Some s ->
            (match SM.find s name_map with
            | exception Caml.Not_found -> acc
            | _ -> G.add_edge acc s tdecl.ptype_name.txt))
    in
    let tdecls_new = T.fold (fun s acc -> SM.find s name_map :: acc) g [] |> List.rev in
    assert (List.length tdecls = List.length tdecls_new);
    tdecls_new
  ;;

  (* for structures *)
  let do_typ ~loc sis plugins is_rec tdecl =
    let (_ : bool) = is_rec in
    let tdecl = rename_params tdecl in
    let intf_class = Str.of_class_declarations ~loc [ make_interface_class ~loc tdecl ] in
    let gcata = make_gcata_str ~loc tdecl in
    let plugins = List.map plugins ~f:(fun p -> p (is_rec, [ tdecl ])) in
    List.concat
      [ sis
      ; [ intf_class; gcata ] (* ; indexes_str ~loc plugins [tdecl] *)
      ; List.concat_map plugins ~f:(fun g -> g#do_single ~loc ~is_rec tdecl)
      ; collect_plugins_str ~loc tdecl [ tdecl ] plugins
      ]
  ;;

  let fix_typ ~loc tdecls =
    let idx = ref 0 in
    let next () =
      Int.incr idx;
      !idx
    in
    let arr3 a b c = Typ.arrow ~loc a (Typ.arrow ~loc b c) in
    let tup ~loc xs =
      match xs with
      | [] -> failwith "bad arguemnt"
      | [ x ] -> x
      | xs -> Typ.tuple ~loc xs
    in
    let ys =
      List.map tdecls ~f:(fun tdecl ->
          let ps = List.map tdecl.ptype_params ~f:(fun _ -> sprintf "a%d" (next ())) in
          let subj_t =
            Typ.constr ~loc (Lident tdecl.ptype_name.txt) @@ List.map ps ~f:(Typ.var ~loc)
          in
          let inhs = List.map ps ~f:(sprintf "%s_i") in
          let syns = List.map ps ~f:(sprintf "%s_s") in
          let main_inh = Typ.var ~loc @@ sprintf "inh%d" (next ()) in
          let main_syn = Typ.var ~loc @@ sprintf "syn%d" (next ()) in
          let cls =
            let args =
              List.map3_exn inhs ps syns ~f:(fun i p s -> [ i; p; s ])
              |> List.concat
              |> List.map ~f:(Typ.var ~loc)
              |> fun xs ->
              xs
              @ [ main_inh
                ; (if is_polyvariant_tdecl tdecl then openize_poly ~loc else id) subj_t
                ; main_syn
                ]
            in
            Typ.class_ ~loc (Lident (Naming.class_name_for_typ tdecl.ptype_name.txt)) args
          in
          let trf = arr3 main_inh subj_t main_syn in
          trf, cls)
    in
    let mutuals = tup ~loc @@ List.map ys ~f:fst in
    List.fold_right
      ~init:(tup ~loc @@ List.map ys ~f:fst)
      ys
      ~f:(fun (_trf, cls) acc -> Typ.arrow ~loc (Typ.arrow ~loc mutuals cls) acc)
  ;;

  let fix_sig ~loc tdecls =
    Sig.value
      ~loc
      ~name:(sprintf "%s" @@ Naming.make_fix_name tdecls)
      (fix_typ ~loc tdecls)
  ;;

  let fix_str ~loc tdecls =
    value_binding
      ~loc
      ~pat:(Pat.sprintf ~loc "%s" @@ Naming.make_fix_name tdecls)
      ~expr:
        Exp.(
          fun_list
            ~loc
            (List.map tdecls ~f:(fun { ptype_name } ->
                 Pat.sprintf ~loc "%s0" ptype_name.txt))
          @@ Exp.let_
               ~loc
               ~rec_:true
               (List.map tdecls ~f:(fun tdecl ->
                    let e k =
                      Exp.fun_list
                        ~loc
                        (map_type_param_names tdecl.ptype_params ~f:(fun txt ->
                             Pat.sprintf ~loc "f%s" txt))
                        k
                    in
                    let inhsubj k =
                      Exp.fun_list ~loc [ Pat.var ~loc "inh"; Pat.var ~loc "subj" ] k
                    in
                    let gc =
                      Exp.app_list
                        ~loc
                        (Exp.sprintf ~loc "gcata_%s" tdecl.ptype_name.txt)
                        [ Exp.app_list
                            ~loc
                            (Exp.sprintf ~loc "%s0" tdecl.ptype_name.txt)
                            ((Exp.tuple ~loc
                             @@ List.map tdecls ~f:(fun { ptype_name = { txt } } ->
                                    Exp.sprintf ~loc "trait%s" txt))
                            :: map_type_param_names tdecl.ptype_params ~f:(fun txt ->
                                   Exp.sprintf ~loc "f%s" txt)
                               (* @
                                * [Exp.app_list ~loc
                                *    (Exp.sprintf ~loc "trait%s" tdecl.ptype_name.txt)
                                *    (map_type_param_names tdecl.ptype_params
                                *       ~f:(fun txt -> Exp.sprintf ~loc "f%s" txt))
                                * ] *))
                        ; Exp.ident ~loc "inh"
                        ; Exp.ident ~loc "subj"
                        ]
                    in
                    Pat.sprintf ~loc "trait%s" tdecl.ptype_name.txt, e @@ inhsubj @@ gc))
          @@ Exp.tuple
               ~loc
               (List.map tdecls ~f:(fun { ptype_name } ->
                    Exp.sprintf ~loc "trait%s" ptype_name.txt)))
    |> Str.of_vb ~loc ~rec_flag:Nonrecursive
    |> List.return
  ;;

  let collect_plugins_sig ~loc tdecls plugins =
    List.concat_map tdecls ~f:(fun tdecl ->
        let wrap () =
          [ Sig.value ~loc ~name:tdecl.ptype_name.txt
            @@ Typ.constr
                 ~loc
                 (Ldot (lident "GT", "t"))
                 [ make_gcata_typ ~loc tdecl
                 ; Typ.object_ ~loc Closed
                   @@ List.map plugins ~f:(fun p ->
                          p#trait_name, p#make_final_trans_function_typ ~loc tdecl)
                   (* ; make_gcata_typ ~loc tdecl *)
                 ; fix_typ ~loc tdecls
                 ]
          ]
        in
        visit_typedecl
          ~loc
          tdecl
          ~onabstract:(fun _ -> [])
          ~onmanifest:(fun _ -> wrap ())
          ~onvariant:(fun _ -> wrap ())
          ~onrecord:(fun _ -> wrap ()))
  ;;

  let do_mutual_types ~loc sis plugins tdecls =
    let tdecls = topsort_tdecls tdecls in
    let classes, catas =
      let all =
        List.map tdecls ~f:(fun tdecl ->
            make_interface_class ~loc tdecl, make_gcata_str ~loc tdecl)
      in
      List.map ~f:fst all, List.map ~f:snd all
    in
    let plugins = List.map plugins ~f:(fun p -> p (true, tdecls)) in
    List.concat
      [ sis
      ; List.map classes ~f:(fun c -> Str.of_class_declarations ~loc [ c ])
      ; catas
      ; fix_str ~loc tdecls
      ; List.concat_map plugins ~f:(fun g -> g#do_mutuals ~loc ~is_rec:true tdecls)
      ; List.concat_map tdecls ~f:(fun tdecl ->
            collect_plugins_str ~loc tdecl tdecls plugins)
      ]
  ;;

  (* for signatures *)
  let do_typ_sig ~loc sis plugins is_rec tdecl =
    let plugins = List.map plugins ~f:(fun p -> p (is_rec, [ tdecl ])) in
    let intf_class = make_interface_class_sig ~loc tdecl in
    let gcata = make_gcata_sig ~loc tdecl in
    (* Pprintast.signature_item Format.std_formatter @@
     *   psig_type ~loc:tdecl.ptype_loc Nonrecursive [tdecl]; *)
    List.concat
      [ sis
      ; intf_class
      ; gcata
      ; List.concat_map plugins ~f:(fun g -> g#do_single_sig ~loc ~is_rec tdecl)
      ; collect_plugins_sig ~loc [ tdecl ] plugins
      ]
  ;;

  let do_mutual_types_sig ~loc sis plugins tdecls =
    (* TODO: it could be a bug with topological sorting here *)
    sis
    @ List.concat_map tdecls ~f:(fun tdecl ->
          List.concat [ make_interface_class_sig ~loc tdecl; make_gcata_sig ~loc tdecl ])
    @ [ fix_sig ~loc tdecls ]
    @ List.concat_map plugins ~f:(fun p ->
          (p (true, tdecls))#do_mutuals_sigs ~loc ~is_rec:true)
    @ (* (List.concat_map tdecls ~f:(fun tdecl ->
       *      List.concat_map plugins ~f:(fun p ->
       *          collect_plugins_sig ~loc tdecl (p tdecls))
       *    )
       * ) @ *)
    collect_plugins_sig ~loc tdecls (List.map plugins ~f:(fun p -> p (true, tdecls)))
  ;;

  (* TODO: collect plugins for mutual types *)
  (* List.concat_map ~f:(do_typ_sig ~loc [] plugins true) tdecls *)

  let wrap_plugin name = function
    | Skip -> id
    | Use args ->
      (match List.Assoc.find config.registered_plugins name ~equal:String.equal with
      | Some m ->
        let module F = (val m : Plugin_intf.MAKE) in
        let module P = F (AstHelpers) in
        List.cons @@ P.create args
      | None -> failwithf "Plugin '%s' is not registered" name ())
  ;;

  (* let sig_type_decl ~loc ~path si
   *     ?(use_show=skip) ?(use_gmap=skip) ?(use_foldl=skip) ?(use_show_type=skip)
   *     ?(use_compare=skip) ?(use_eq=skip)
   *     (rec_flag, tdls) =
   *   let plugins =
   *     wrap_plugin "show"        use_show  @@
   *     wrap_plugin "compare"     use_compare @@
   *     wrap_plugin "gmap"        use_gmap  @@
   *     wrap_plugin "foldl"       use_foldl @@
   *     wrap_plugin "show_typed"  use_show_type @@
   *     wrap_plugin "eq"          use_eq @@
   *     []
   *   in
   *   match rec_flag, tdls with
   *   | recursive, []      -> []
   *   | recursive, [tdecl] -> do_typ_sig si ~loc plugins true tdecl
   *   | recursive, ts      -> do_mutal_types_sig ~loc plugins ts
   *   | nonrecursive, tdls ->
   *       list.concat_map ~f:(do_typ_sig ~loc si plugins false) tdls *)

  let sig_type_decl_many_plugins ~loc si plugins_info declaration =
    let plugins =
      List.fold_left plugins_info ~init:[] ~f:(fun acc (name, args) ->
          wrap_plugin name args acc)
    in
    let declaration = fst declaration, List.map ~f:rename_params (snd declaration) in
    match declaration with
    | Recursive, [] -> []
    | Recursive, [ tdecl ] -> do_typ_sig si ~loc plugins true tdecl
    | Recursive, ts ->
      (* Stdio.printf "Got %d declarations\n%!" (List.length ts); *)
      do_mutual_types_sig ~loc si plugins ts
    | Nonrecursive, tdls -> List.concat_map ~f:(do_typ_sig ~loc si plugins false) tdls
  ;;

  let str_type_decl_many_plugins ~loc si plugins_info declaration =
    let plugins =
      List.fold_left plugins_info ~init:[] ~f:(fun acc (name, args) ->
          wrap_plugin name args acc)
    in
    match declaration with
    | Recursive, [] -> []
    | Recursive, [ tdecl ] -> do_typ ~loc si plugins true tdecl
    | Recursive, ts -> do_mutual_types ~loc si plugins ts
    | Nonrecursive, decls -> List.concat_map ~f:(do_typ ~loc si plugins false) decls
  ;;

  let str_type_ext_many_plugins ~loc si plugins_info extension = []
end

(* part of old implementation where we are trying to collect all values in t
 * first-class module. but we decided to roll back because we can't write
 * generic function to access it *)
let name_fcm_mt tdecl = sprintf "mt_%s" tdecl.ptype_name.txt
(* let gather_module_str tdecl plugins =
 *   let loc = tdecl.ptype_loc in
 *
 *   let body = [%stri let gcata =
 *                       [%e exp.sprintf "gcata_%s" tdecl.ptype_name.txt] ] ::[]
 *   in
 *   let body = list.fold_left ~init:body plugins
 *       ~f:(fun acc p ->
 *         let expr = exp.sprintf ~loc "%s" @@ p#make_trans_function_name tdecl in
 *         str.single_value ~loc (pat.of_string ~loc p#plugin_name) expr
 *         :: acc
 *       )
 *   in
 *   let expr = exp.pack_with_constraint ~loc
 *       (mod.structure ~loc @@ list.rev body)
 *       (located.lident ~loc (name_fcm_mt tdecl))
 *   in
 *   str.single_value ~loc (pat.sprintf "%s" tdecl.ptype_name.txt) expr *)

(* let make_fcm_sig ~loc tdecl plugins =
 *   let fields = list.concat_map plugins ~f:(fun p ->
 *       let name  = p#plugin_name in
 *       let type_ = p#make_trans_function_typ tdecl in
 *       [sig.value ~loc ~name type_ ]
 *     )
 *   in
 *   mty.signature ~loc ((make_gcata_sig ~shortname:true ~loc tdecl) :: fields )
 *
 * let prepare_mt ~loc tdecl plugins =
 *     let name = located.mk ~loc @@ sprintf "mt_%s" tdecl.ptype_name.txt in
 *     let type_ = some (make_fcm_sig ~loc tdecl plugins) in
 *     str.modtype ~loc (module_type_declaration ~loc ~name ~type_) *)