Source file ptyp_of_type.ml

open Std
open Typedtree
open Types

let var_of_id id = Location.mknoloc @@ Ident.name id

type signature_elt =
  | Item of Types.signature_item
  | Type of Asttypes.rec_flag * Parsetree.type_declaration list

let rec module_type =
  let open Ast_helper in function
  | Mty_for_hole -> failwith "Holes are not allowed in module types"
  | Mty_signature signature_items ->
    Mty.signature @@ signature signature_items
  | Mty_ident path ->
    Ast_helper.Mty.ident (Location.mknoloc (Untypeast.lident_of_path path))
  | Mty_alias path ->
    Ast_helper.Mty.alias (Location.mknoloc (Untypeast.lident_of_path path))
  | Mty_functor (param, type_out) ->
    let param = match param with
      | Unit -> Parsetree.Unit
      | Named (id, type_in) ->
        Parsetree.Named (
          Location.mknoloc (Option.map ~f:Ident.name id),
          module_type type_in)
    in
    let out = module_type type_out in
    Mty.functor_ param out
and core_type type_expr =
  let open Ast_helper in
  match Types.get_desc type_expr with
  | Tvar None | Tunivar None -> Typ.any ()
  | Tvar (Some s) | Tunivar (Some s) -> Typ.var s
  | Tarrow (label, type_expr, type_expr_out, _commutable) ->
    Typ.arrow label
      (core_type type_expr)
      (core_type type_expr_out)
  | Ttuple type_exprs -> Typ.tuple @@ List.map ~f:core_type type_exprs
  | Tconstr (path, type_exprs, _abbrev) ->
    let loc = Untypeast.lident_of_path path |> Location.mknoloc in
    Typ.constr loc @@ List.map ~f:core_type type_exprs
  | Tobject (type_expr, _class_) ->
    let rec aux acc type_expr = match get_desc type_expr with
      | Tnil -> acc, Asttypes.Closed
      | Tvar None | Tunivar None -> acc, Asttypes.Open
      | Tfield ("*dummy method*", _, _, fields) -> aux acc fields
      | Tfield (name, _, type_expr, fields) ->
        let open Ast_helper in
        let core_type = core_type type_expr in
        let core_type = Of.tag (Location.mknoloc name) core_type in

        aux (core_type :: acc) fields
      | _ ->
        failwith @@ Format.asprintf
          "Unexpected type constructor in fields list: %a"
          Printtyp.type_expr type_expr
    in
    let fields, closed = aux [] type_expr in
    Typ.object_ fields closed
  | Tfield _ ->  failwith "Found object field outside of object."
  | Tnil -> Typ.object_ [] Closed
  | Tlink type_expr | Tsubst (type_expr, _) -> core_type type_expr
  | Tvariant row ->
    let row_fields = row_fields row in
    let row_closed = row_closed row in
    let field (label, row_field) =
      let label = Location.mknoloc label in
      match row_field_repr row_field with
      | Rpresent None | Reither (true, _, _) ->
        Rf.tag label true []
      | Rpresent (Some type_expr) ->
        let core_type = core_type type_expr in
        Rf.tag label false [ core_type ]
      | Reither (false, type_exprs, _) ->
        Rf.tag label false @@ List.map ~f:core_type type_exprs
      | Rabsent -> assert false
    in
    let closed = if row_closed then Asttypes.Closed else Asttypes.Open in
    let fields = List.map ~f:field row_fields in
    (* TODO NOT ALWAYS NONE *)
    Typ.variant fields closed None
  | Tpoly (type_expr, type_exprs) ->
    let names = List.map ~f:(fun v -> match get_desc v with
      | Tunivar (Some name) | Tvar (Some name) -> mknoloc name
      | _ -> failwith "poly: not a var")
      type_exprs
    in
    Typ.poly names @@ core_type type_expr
  | Tpackage (path, lids_type_exprs) ->
    let loc = mknoloc (Untypeast.lident_of_path path) in
    let args = List.map lids_type_exprs
      ~f:(fun (id, t) -> mknoloc id, core_type t)
    in
    Typ.package loc args
and modtype_declaration id { mtd_type; mtd_attributes; _ } =
  Ast_helper.Mtd.mk
    ~attrs:mtd_attributes
    ?typ:(Option.map ~f:module_type mtd_type)
    (var_of_id id)
and module_declaration id { md_type; md_attributes; _ } =
 let name = Location.mknoloc (Some (Ident.name id)) in
 Ast_helper.Md.mk
  ~attrs:md_attributes
  name
  @@ module_type md_type
and extension_constructor id {
  ext_args;
  ext_ret_type;
  ext_attributes;
  _
} =
  Ast_helper.Te.decl
    ~attrs:ext_attributes
    ~args:(constructor_arguments ext_args)
    ?res:(Option.map ~f:core_type ext_ret_type)
    (var_of_id id)
and value_description id { val_type; val_kind=_; val_loc; val_attributes; _ } =
  let type_ = core_type val_type in
  {
    Parsetree.pval_name = var_of_id id;
    pval_type = type_;
    pval_prim = [];
    pval_attributes = val_attributes;
    pval_loc = val_loc
  }
and label_declaration { ld_id; ld_mutable; ld_type; ld_attributes; _ } =
  Ast_helper.Type.field
    ~attrs:ld_attributes
    ~mut:ld_mutable
    (var_of_id ld_id)
    (core_type ld_type)
and constructor_arguments = function
  | Cstr_tuple type_exprs ->
    Parsetree.Pcstr_tuple (List.map ~f:core_type type_exprs)
  | Cstr_record label_decls ->
    Parsetree.Pcstr_record (List.map ~f:label_declaration label_decls)
and constructor_declaration { cd_id; cd_args; cd_res; cd_attributes; _} =
  Ast_helper.Type.constructor
    ~attrs:cd_attributes
    ~args:(constructor_arguments cd_args)
    ?res:(Option.map ~f:core_type cd_res)
    @@ var_of_id cd_id
and type_declaration id {
  type_params;
  type_variance;
  type_manifest;
  type_kind;
  type_attributes;
  type_private;
  _ }
  =
  let params = List.map2 type_params type_variance ~f:(fun type_ variance ->
    let core_type = core_type type_ in
    let pos, neg, _inv, inj = Types.Variance.get_lower variance in
    let v = if pos then  Asttypes.Covariant
      else (if neg then Contravariant
      else NoVariance)
    in
    let i = if inj then Asttypes.Injective else NoInjectivity in
    core_type, (v, i))
  in
  let kind = match type_kind with
    | Type_abstract -> Parsetree.Ptype_abstract
    | Type_open -> Ptype_open
    | Type_variant (constrs, _) ->
      Ptype_variant (List.map ~f:constructor_declaration constrs)
    | Type_record (labels, _repr) ->
      Ptype_record (List.map ~f:label_declaration labels)
  in
  let manifest = Option.map ~f:core_type type_manifest in
  Ast_helper.Type.mk
    ~attrs:type_attributes
    ~params
    ~kind
    ~priv:type_private
    ?manifest
    (var_of_id id)
and signature_item (str_item : Types.signature_item) =
  let open Ast_helper in
  match str_item with
  | Sig_value (id, vd, _visibility) ->
    let vd = value_description id vd in
    Sig.value  vd
  | Sig_type (id, type_decl, rec_flag, _visibility) ->
    let rec_flag = match rec_flag with
      | Trec_first -> Asttypes.Recursive
      | Trec_next -> Asttypes.Recursive
      | Trec_not -> Nonrecursive
    in (* mutually recursive types are really handled by [signature] *)
    Sig.type_ rec_flag [type_declaration id type_decl]
  | Sig_modtype (id, modtype_decl, _visibility) ->
    Sig.modtype @@ modtype_declaration id modtype_decl
  | Sig_module (id, _, mod_decl, _, _) ->
    Sig.module_ @@ module_declaration id mod_decl
  | Sig_typext (id, ext_constructor, _, _) ->
    let ext = Te.mk
      (Location.mknoloc @@ Longident.Lident (Ident.name id))
      [ extension_constructor id ext_constructor]
    in
    Sig.type_extension ext
  | Sig_class_type (id, _, _, _) ->
    let str = Format.asprintf "Construct does not handle class types yet. \
    Please replace this comment by [%s]'s definition." (Ident.name id) in
    Sig.text [ Docstrings.docstring str Location.none ] |> List.hd
  | Sig_class (id, _, _, _) ->
    let str = Format.asprintf "Construct does not handle classes yet. \
    Please replace this comment by [%s]'s definition." (Ident.name id) in
    Sig.text [ Docstrings.docstring str Location.none ] |> List.hd
and signature  (items : Types.signature_item list) =
  List.map (group_items items)
    ~f:(function
    | Item item -> signature_item item
    | Type (rec_flag, type_decls) -> Ast_helper.Sig.type_  rec_flag type_decls)
and group_items (items : Types.signature_item list) =
  let rec read_type type_acc items =
    match items with
    | Sig_type (id, type_decl, Trec_next, _) :: rest ->
      let td = type_declaration id type_decl in
      read_type (td :: type_acc) rest
    | _ -> List.rev type_acc, items
  in
  let rec group acc items =
    match items with
    | Sig_type (id, type_decl, Trec_first, _) :: rest ->
      let type_, rest = read_type [type_declaration id type_decl] rest in
      group (Type (Asttypes.Recursive, type_) :: acc) rest
    | Sig_type (id, type_decl, Trec_not, _) :: rest ->
      let type_, rest = read_type [type_declaration id type_decl] rest in
      group (Type (Asttypes.Nonrecursive, type_) :: acc) rest
    | Sig_class _ as item :: _ :: _ :: _ :: rest ->
      group (Item item :: acc) rest
    | Sig_class_type _ as item :: _ :: _ :: rest ->
      group (Item item :: acc) rest
    | item :: rest -> group (Item item :: acc) rest
    | [] -> List.rev acc
  in
  group [] items