Source file expander.ml

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

open Ppxlib
open Stdppx
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_ascii 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_ascii 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_ascii 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 (struct
    include String

    let hash = Hashtbl.hash
  end)

  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 sort_decls =
    List.sort ~cmp:(fun { ptype_name = { txt = l } } { ptype_name = { txt = r } } ->
      String.compare l r)
  ;;

  let fix_typ ~loc tdecls =
    let idx = ref 0 in
    let next () =
      Stdlib.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 argument"
      | [ x ] -> x
      | xs -> Typ.tuple ~loc xs
    in
    match tdecls with
    | [] -> failwith "should not happen"
    | [ tdecl ] ->
      (* Single definition is simple *)
      (* TODO: Maybe we can reuse creation of gcata's signature  *)
      (* TODO: merge common parts with next general case  *)
      let ps = map_type_param_names tdecl.ptype_params ~f:Fun.id in
      let subj_t =
        Typ.constr ~loc (Lident tdecl.ptype_name.txt) @@ List.map ps ~f:(Typ.var ~loc)
      in
      let main_inh = Typ.var ~loc @@ sprintf "inh%d" (next ()) in
      let main_syn = Typ.var ~loc @@ sprintf "syn%d" (next ()) in
      let trf = arr3 main_inh subj_t main_syn in
      let fixpoint =
        let self_typ =
          Typ.constr ~loc (Lident tdecl.ptype_name.txt)
          @@ map_type_param_names tdecl.ptype_params ~f:(Typ.var ~loc)
        in
        let class_ =
          Typ.class_
            ~loc
            (Lident (class_name_for_typ tdecl.ptype_name.txt))
            (List.concat_map ps ~f:(fun s -> [ main_inh; Typ.var ~loc s; main_syn ])
             @ [ main_inh; (*openize_poly ~loc @@*) self_typ; main_syn ])
        in
        Typ.arrow ~loc (arr3 main_inh self_typ main_syn) class_
      in
      Typ.chain_arrow ~loc [ fixpoint; trf ]
    | tdecls ->
      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 add_trf x =
            List.map3_exn inhs ps syns ~f:(fun i p s ->
              Typ.var ~loc i, Typ.var ~loc p, Typ.var ~loc s)
            |> List.fold_right
                 ~f:(fun (i, p, s) acc -> Typ.arrow ~loc (arr3 i p s) acc)
                 ~init:x
          in
          ( sprintf "alias_for_%s" tdecl.ptype_name.txt
          , add_trf (arr3 main_inh subj_t main_syn)
          , add_trf cls ))
      in
      let fix_arg =
        tup ~loc
        @@ List.map tdecls ~f:(fun { ptype_name = { txt } } ->
             Typ.var ~loc (sprintf "alias_for_%s" txt))
      in
      List.fold_right
        ys
        ~init:(tup ~loc @@ List.map ys ~f:(fun (name, x, _) -> Typ.alias ~loc x name))
        ~f:(fun (name, _, cls) acc -> Typ.arrow ~loc (Typ.arrow ~loc fix_arg 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 =
    (* let tdecls = sort_decls tdecls |> List.rev in *)
    (* 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 -> failwiths "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 (sort_decls ts)
    | Nonrecursive, tdls ->
      List.concat_map ~f:(do_typ_sig ~loc si plugins false) (sort_decls 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 (sort_decls 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_) *)