(* {{{ COPYING *(

  This file is part of Merlin, an helper for ocaml editors

  Copyright (C) 2013 - 2015  Frédéric Bour  <frederic.bour(_)lakaban.net>
                             Thomas Refis  <refis.thomas(_)gmail.com>
                             Simon Castellan  <simon.castellan(_)iuwt.fr>
                             Jeremie Dimino  <jeremie(_)dimino.org>

  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the "Software"),
  to deal in the Software without restriction, including without limitation the
  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  sell copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  The Software is provided "as is", without warranty of any kind, express or
  implied, including but not limited to the warranties of merchantability,
  fitness for a particular purpose and noninfringement. In no event shall
  the authors or copyright holders be liable for any claim, damages or other
  liability, whether in an action of contract, tort or otherwise, arising
  from, out of or in connection with the software or the use or other dealings
  in the Software.

)* }}} *)

open Std

open Browse_raw

open Extend_protocol.Reader

let {Logger. log} = Logger.for_section "Completion"

type raw_info =
  [ `Constructor of Types.constructor_description
  | `Modtype of Types.module_type
  | `Modtype_declaration of Ident.t * Types.modtype_declaration
  | `None
  | `String of string
  | `Type_declaration of Ident.t * Types.type_declaration
  | `Type_scheme of Types.type_expr
  | `Variant of string * Types.type_expr option
  ]

let raw_info_printer : raw_info -> _ = function
  | `Constructor c ->
    `Print (Out_type (Browse_misc.print_constructor c))
  | `Modtype mt ->
    `Print (Out_module_type (Printtyp.tree_of_modtype mt))
  | `Modtype_declaration (id, mtd) ->
    `Print (Out_sig_item
              (Printtyp.tree_of_modtype_declaration id mtd))
  | `None -> `String ""
  | `String s -> `String s
  | `Type_declaration (id, tdecl) ->
    `Print (Out_sig_item
              (Printtyp.tree_of_type_declaration id tdecl Types.Trec_first))
  | `Type_scheme te ->
    `Print (Out_type (Printtyp.tree_of_type_scheme te))
  | `Variant (label, arg) ->
    begin match arg with
      | None -> `String label
      | Some te ->
        `Concat (label ^ " of ",
                 Out_type (Printtyp.tree_of_type_scheme te))
    end

(* List methods of an object.
   Code taken from [uTop](https://github.com/diml/utop
   with permission from Jeremie Dimino. *)
let lookup_env f x env =
  try Some (f x env)
  with Not_found | Env.Error _ -> None

let rec methods_of_type env ?(acc=[]) type_expr =
  let open Types in
  match get_desc type_expr with
  | Tlink type_expr | Tobject (type_expr, _) | Tpoly (type_expr, _) ->
    methods_of_type env ~acc type_expr
  | Tfield (name, _, ty, rest) ->
    methods_of_type env ~acc:((name,ty) :: acc) rest
  | Tconstr (path, _, _) -> begin
      match lookup_env Env.find_type path env with
      | None | Some { type_manifest = None; _ } -> acc
      | Some { type_manifest = Some type_expr; _ } ->
        methods_of_type env ~acc type_expr
    end
  | _ -> acc

let classify_node = function
  | Dummy                      -> `Expression
  | Pattern                  _ -> `Pattern
  | Expression               _ -> `Expression
  | Case                     _ -> `Pattern
  | Class_expr               _ -> `Expression
  | Class_structure          _ -> `Expression
  | Class_field              _ -> `Expression
  | Class_field_kind         _ -> `Expression
  | Binding_op               _ -> `Expression
  | Module_expr              _ -> `Module
  | Module_type_constraint   _ -> `Module_type
  | Structure                _ -> `Structure
  | Structure_item           _ -> `Structure
  | Module_binding           _ -> `Module
  | Value_binding            _ -> `Type
  | Module_type              _ -> `Module_type
  | Signature                _ -> `Signature
  | Signature_item           _ -> `Signature
  | Module_declaration       _ -> `Module
  | Module_type_declaration  _ -> `Module_type
  | With_constraint          _ -> `Type
  | Core_type                _ -> `Type
  | Package_type             _ -> `Module_type
  | Row_field                _ -> `Expression
  | Value_description        _ -> `Type
  | Type_declaration         _ -> `Type
  | Type_kind                _ -> `Type
  | Type_extension           _ -> `Type
  | Extension_constructor    _ -> `Type
  | Label_declaration        _ -> `Type
  | Constructor_declaration  _ -> `Type
  | Class_type               _ -> `Type
  | Class_signature          _ -> `Type
  | Class_type_field         _ -> `Type
  | Class_declaration        _ -> `Expression
  | Class_description        _ -> `Type
  | Class_type_declaration   _ -> `Type
  | Method_call              _ -> `Expression
  | Record_field             (`Expression _, _, _) -> `Expression
  | Record_field             (`Pattern _, _, _) -> `Pattern
  | Module_binding_name      _ -> `Module
  | Module_declaration_name  _ -> `Module
  | Module_type_declaration_name _ -> `Module_type
  | Open_description _ -> `Module
  | Open_declaration _ -> `Module
  | Include_declaration _ -> `Module
  | Include_description _ -> `Module

open Query_protocol.Compl

let map_entry f entry =
  {entry with desc = f entry.desc; info = f entry.info}

let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty =
  let ident = match path with
    | Some path ->
      (* this is not correct: the ident is not persistent, the printing of some
         polymorphic variant type could (perhaps) be incorrect because of this
         (though I haven't tried to add a test). But it would be incorrect with
         any ident with synthesize at this point anyway.
         And create_persistent is the only function which is available on all
         the versions of ocaml we support. *)
      Ident.create_persistent (Path.last path)
    | None -> Extension.ident
  in
  let kind, text =
    match ty with
    | `Value v ->
      (`Value, `Type_scheme v.Types.val_type)
    | `Cons c  -> (`Constructor, `Constructor c)
    | `Label label_descr ->
      let desc =
        Types.(Tarrow (Ast_helper.no_label,
                       label_descr.lbl_res, label_descr.lbl_arg, commu_ok))
      in
      (`Label, `Type_scheme (Btype.newgenty desc))
    | `Label_decl (ty,label_decl) ->
      let desc =
        Types.(Tarrow (Ast_helper.no_label,
                       ty, label_decl.ld_type, commu_ok))
      in
      (`Label, `Type_scheme (Btype.newgenty desc))
    | `Mod m   ->
      begin try
          if not exact then raise Exit;
          let verbosity =
            Mconfig.Verbosity.to_int !Type_utils.verbosity ~for_smart:1
          in
          if Type_utils.mod_smallerthan (1000 * verbosity) m = None then raise Exit;
          (`Module, `Modtype m)
        with Exit -> (`Module, `None)
      end
    | `ModType m ->
      if exact then
        (`Modtype, `Modtype_declaration (ident, (*verbose_sig env*) m))
      else
        (`Modtype, `None)
    | `Typ t ->
      (`Type, `Type_declaration (ident, t))
    | `Variant (label,arg) ->
      (`Variant, `Variant (label, arg))
  in
  (* FIXME: When suggesting variants (and constructors) with parameters,
     it could be nice to check precedence and add or not parenthesis.
  let name = match ty with
    | `Variant (_, Some _) -> "(" ^ name ^ " )"
    | _ -> name
  in*)
  let name =
    match prefix_path with
    | None -> name
    | Some _ -> Misc_utils.parenthesize_name name
  in
  let desc =
    match kind with
    | `Module | `Modtype -> `None
    | _ -> text
  in
  let info = match Type_utils.read_doc_attributes attrs, get_doc, kind with
    | Some (str, _), _, _ -> `String str
    | None, _, (`Module | `Modtype) -> text
    | None, None, _ -> `None
    | None, Some get_doc, kind ->
      match path, loc with
      | Some p, Some loc ->
        let namespace = (* FIXME: that's just terrible *)
          match kind with
          | `Value -> `Vals
          | `Type -> `Type
          | _ -> assert false
        in
        begin match get_doc (`Completion_entry (namespace, p, loc)) with
          | `Found str -> `String str
          | _ -> `None
          | exception _ -> `None
        end
      | _, _ -> `None
  in
  let deprecated = Type_utils.is_deprecated attrs in
  {name; kind; desc; info; deprecated}

let item_for_global_module name =
  {name; kind = `Module; desc = `None; info = `None; deprecated = false}

let fold_variant_constructors ~env ~init ~f =
  let rec aux acc t =
    match Types.get_desc t with
    | Types.Tvariant row ->
      let row_fields = Types.row_fields row in
      let row_more = Types.row_more row in
      let acc =
        let keep_if_present acc (lbl, row_field) =
          let row_field = Types.row_field_repr row_field in
          match row_field with
          | Types.Rpresent arg when lbl <> "" -> f ("`" ^ lbl) arg acc
          | Types.Reither (_, lst, _) when lbl <> "" ->
            let arg =
              match lst with
              | [ well_typed ] -> Some well_typed
              | _ -> None
            in
            f ("`" ^ lbl) arg acc
          | _ -> acc
        in
        List.fold_left ~init:acc row_fields ~f:keep_if_present
      in
      aux acc row_more
    | Types.Tconstr _ ->
      let t' = try Ctype.full_expand env ~may_forget_scope:true t with _ -> t in
      if Types.TransientTypeOps.equal
        (Types.Transient_expr.repr t)
        (Types.Transient_expr.repr t')
      then
        acc
      else
        aux acc t'
    | _ -> acc
  in
  aux init

let fold_sumtype_constructors ~env ~init ~f t =
  let t = Types.Transient_expr.repr t in
  match t.desc with
  | Tconstr (path, _, _) ->
    log ~title:"fold_sumtype_constructors" "node type: %s"
      (Path.name path);
    begin match Env.find_type_descrs path env with
    | exception Not_found -> init
    | Type_record _ | Type_abstract | Type_open -> init
    | Type_variant (constrs, _) ->
      List.fold_right constrs ~init ~f
    end
  | _ ->
    init

let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env branch =
  let cstr_attributes c = c.Types.cstr_attributes in
  let val_attributes v = v.Types.val_attributes in
  let type_attributes t = t.Types.type_attributes in
  let lbl_attributes l = l.Types.lbl_attributes in
  let mtd_attributes t = t.Types.mtd_attributes in
  let md_attributes t = t.Types.md_attributes in
  let make_candidate ~attrs ~exact name ?loc ?path ty =
    make_candidate ~get_doc ~prefix_path ~attrs ~exact name ?loc ?path ty in
  let make_weighted_candidate ?(priority=0) ~attrs ~exact name ?loc ?path ty =
    (* Just like [make_candidate] but associates some metadata to the candidate.
       The candidates are later sorted using these metadata.

       The ordering works as follow:
       - first we compare the priority of the candidates
       - we compare the cost of unification for both (using Btype.total_changes)
       - if they are equal, then we compare their "binding time": things
         introduced more recently will come before older bindings (i.e. we
         prioritize the local context)
       - if these are also equal, then we just use classic string ordering on
         the candidate name. *)
    let time =
      try Path.scope (Option.get path)
      with _ -> 0
    in
    let item = make_candidate ~attrs ~exact name ?loc ?path ty in
    (- priority, - time, name), item
  in
  let is_internal name = name = "" || name.[0] = '_' in
  let items =
    let snap = Btype.snapshot () in
    let rec arrow_arity n t =
      match Types.get_desc t with
      | Types.Tarrow (_,_,rhs,_) -> arrow_arity (n + 1) rhs
      | _ -> n
    in
    let rec nth_arrow n t =
      if n <= 0 then t else
      match Types.get_desc t with
      | Types.Tarrow (_,_,rhs,_) -> nth_arrow (n - 1) rhs
      | _ -> t
    in
    let type_check =
      (* Defines the priority of a candidate.
         Priority is 1000 - cost - head_arrows, where:
         - cost is the number unification variables instantiated to make the types unify
         - head_arrows is 0 if types unified, or the number of arrows which
           have been skipped to make them unify (i.e types would unify if the
           user apply the function to head_arrows arguments).
         Note that if no type is expected (context was not inferred), 0 will be
         returned. *)
      match target_type with
      | None -> fun _ -> 0
      | Some ty ->
        let arity = arrow_arity 0 ty in
        fun scheme ->
        let cost =
          let c = Types.linked_variables in
          try
            let c' = c () in
            Ctype.unify_var env ty (Ctype.instance scheme);
            c () - c'
          with _ ->
            let arity = arrow_arity (-arity) scheme in
            if arity > 0 then begin
              let c' = c () in
              Btype.backtrack snap;
              let ty' = Ctype.instance scheme in
              let ty' = nth_arrow arity ty' in
              try Ctype.unify_var env ty ty'; arity + c () - c'
              with _ -> 1000
            end
            else 1000
        in
        Btype.backtrack snap;
        1000 - cost
    in
    let of_kind = function
      | `Keywords -> [] (* cannot happen after a dot. *)
      | `Variants ->
        let add_variant name param candidates =
          if not @@ validate `Variant `Variant name then candidates else
            make_weighted_candidate name ~exact:false ~priority:2 ~attrs:[]
              (`Variant (name, param))
            :: candidates
        in
        let result = match target_type with
          | None -> []
          | Some t -> fold_variant_constructors t ~init:[] ~f:add_variant ~env
        in
        let result = match branch with
          | _ :: (_, Expression {Typedtree. exp_type = t; _}) :: _
          | (_, Expression {Typedtree. exp_type = t; _}) :: _ ->
            fold_variant_constructors t ~init:result ~f:add_variant ~env
          | _ -> result
        in
        result
      | `Values ->
        let type_check {Types. val_type; _} = type_check val_type in
        Env.fold_values (fun name path v candidates ->
          if not (validate `Lident `Value name) then candidates else
          let priority = if is_internal name then 0 else type_check v in
          make_weighted_candidate ~exact:(name = prefix) name ~priority ~path
            ~attrs:(val_attributes v)
            (`Value v) ~loc:v.Types.val_loc
          :: candidates
        ) prefix_path env []

      | `Constructor ->
        let type_check {Types. cstr_res; _} = type_check cstr_res in
        let consider_constr constr candidates =
          let name = constr.Types.cstr_name in
          if not @@ validate `Lident `Cons name then candidates else
          let priority = if is_internal name then 0 else type_check constr in
          make_weighted_candidate ~exact:(name=prefix) name (`Cons constr)
            ~priority ~attrs:(cstr_attributes constr)
          :: candidates
        in
        let in_scope_candidates =
          Env.fold_constructors consider_constr prefix_path env []
        in
        begin match prefix_path, target_type with
        | Some _, _
        | _, None -> in_scope_candidates
        | None, Some ty ->
          fold_sumtype_constructors ~env ~init:in_scope_candidates
            ~f:consider_constr ty
        end

      | `Types ->
        Env.fold_types (fun name path decl candidates ->
          if not @@ validate `Lident `Typ name then candidates else
          make_weighted_candidate ~exact:(name = prefix) name ~path (`Typ decl)
            ~loc:decl.Types.type_loc ~attrs:(type_attributes decl)
          :: candidates
        ) prefix_path env []

      | `Modules ->
        Env.fold_modules (fun name path v candidates ->
          let attrs = md_attributes v in
          let v = v.Types.md_type in
          if not @@ validate `Uident `Mod name then candidates else
            make_weighted_candidate ~exact:(name = prefix) name ~path (`Mod v) ~attrs
          :: candidates
        ) prefix_path env []

      | `Modules_type ->
        Env.fold_modtypes (fun name path v candidates ->
          if not @@ validate `Uident `Mod name then candidates else
            make_weighted_candidate ~exact:(name=prefix) name ~path (`ModType v)
              ~attrs:(mtd_attributes v)
            :: candidates
        ) prefix_path env []

      | `Labels ->
        Env.fold_labels (fun ({Types.lbl_name = name; _} as l) candidates ->
          if not (validate `Lident `Label name) then candidates else
            make_weighted_candidate ~exact:(name = prefix) name (`Label l)
              ~attrs:(lbl_attributes l)
            :: candidates
        ) prefix_path env []
    in
    let of_kind_group = function
      | #Query_protocol.Compl.kind as k -> of_kind k
      | `Group kinds -> List.concat_map ~f:of_kind kinds
    in
    try of_kind_group kind
    with exn ->
      log ~title:"get_candidates/of_kind"
        "Failed with exception: %a" Logger.exn exn;
      []
  in
  let items = List.sort items ~cmp:(fun (a,_) (b,_) -> compare a b) in
  let items = List.rev_map ~f:snd items in
  items

let gen_values = `Group [`Values; `Constructor]

let default_kinds = [`Variants; gen_values; `Types; `Modules; `Modules_type]

let completion_order = function
  | `Expression  -> [`Variants; gen_values; `Types; `Modules; `Modules_type]
  | `Structure   -> [gen_values; `Types; `Modules; `Modules_type]
  | `Pattern     -> [`Variants; `Constructor; `Modules; `Labels; `Values; `Types; `Modules_type]
  | `Module      -> [`Modules; `Modules_type; `Types; gen_values]
  | `Module_type -> [`Modules_type; `Modules; `Types; gen_values]
  | `Signature   -> [`Types; `Modules; `Modules_type; gen_values]
  | `Type        -> [`Types; `Modules; `Modules_type; gen_values]

type kinds = [kind | `Group of kind list] list

let complete_methods ~env ~prefix obj =
  let t = obj.Typedtree.exp_type in
  let has_prefix (name,_) =
    String.is_prefixed ~by:prefix name &&
    (* Prevent identifiers introduced by type checker to leak *)
    try ignore (String.index name ' ' : int); false
    with Not_found -> true
  in
  let methods = List.filter ~f:has_prefix (methods_of_type env t) in
  List.map methods ~f:(fun (name,ty) ->
    let info = `None (* TODO: get documentation. *) in
    { name; kind = `MethodCall; desc = `Type_scheme ty; info; deprecated = false }
  )

type is_label =
  [ `No | `Maybe
  | `Description of Types.label_description list
  | `Declaration of Types.type_expr * Types.label_declaration list
  ]

let complete_prefix ?get_doc ?target_type ?(kinds=[]) ~keywords ~prefix
    ~is_label config (env,node) branch =
  Env.with_cmis @@ fun () ->
  let seen = Hashtbl.create 7 in
  let uniq n = if Hashtbl.mem seen n
    then false
    else (Hashtbl.add seen n (); true)
  in
  let make_candidate ~attrs ~exact name ?loc ?path ty =
    make_candidate ~get_doc ~attrs ~exact name ?loc ?path ty in
  let find ?prefix_path ~is_label prefix =
    let valid tag name =
      let no_leak () =
        (* Prevent identifiers introduced by type checker
          and recovery to leak *)
        List.for_all ~f:(fun by -> not (String.is_prefixed ~by name))
          ["self-"; "selfpat-"; "*type-"]
      in
      String.is_prefixed ~by:prefix name
      && uniq (tag,name)
      && no_leak ()
    in
    (* Hack to prevent extensions namespace to leak
       + another to hide the "Library_name__Module" present at Jane Street *)
    let validate ident tag name =
      (if ident = `Uident
       then name <> "" && name.[0] <> '_'
            && (String.no_double_underscore name || tag <> `Mod)
       else name <> "_")
      && valid tag name
    in
    let add_label_description ({Types.lbl_name = name; _} as l) candidates =
      if not (valid `Label name) then candidates else
        make_candidate ~prefix_path ~exact:(name = prefix) name
          (`Label l) ~attrs:[]
        :: candidates
    in
    let add_label_declaration ty ({Types.ld_id = name; _} as l) candidates =
      let name = Ident.name name in
      if not (valid `Label name) then candidates else
        make_candidate ~prefix_path ~exact:(name = prefix) name
          (`Label_decl (ty,l)) ~attrs:[]
        :: candidates
    in
    let base_completion = match (is_label : is_label) with
      | `No -> []
      | `Maybe ->
        Env.fold_labels add_label_description prefix_path env []
      | `Description lbls ->
        List.fold_right ~f:add_label_description lbls ~init:[]
      | `Declaration (ty,decls) ->
        List.fold_right ~f:(add_label_declaration ty) decls ~init:[]
    in
    if base_completion = [] then
      let order =
        if kinds = [] then
          let kind = classify_node node in
          completion_order kind
        else
          (kinds : kind list :> kinds)
      in
      let add_completions acc kind =
        get_candidates
          ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env branch
        :: acc
      in
      List.fold_left ~f:add_completions order ~init:[]
      |> List.concat
    else base_completion
  in
  try
    match prefix with
    | Longident.Ldot (prefix_path, prefix) -> find ~prefix_path ~is_label prefix
    | Longident.Lident prefix ->
      (* Regular completion *)
      let compl = find ~is_label prefix in
      (* Keywords completion *)
      let compl =
        if not (List.mem `Keywords ~set:kinds) then
          compl
        else
          List.fold_left keywords ~init:compl ~f:(fun candidates name ->
            if String.is_prefixed ~by:prefix name then
              { name; kind = `Keyword; desc = `None; info = `None
              ; deprecated = false }
              :: candidates
            else
              candidates
          )
      in
      (* Add modules on path but not loaded *)
      List.fold_left (Mconfig.global_modules config) ~init:compl ~f:(
        fun candidates name ->
          if not (String.no_double_underscore name) then candidates else
          let default =
            { name; kind = `Module; desc = `None; info = `None; deprecated = false } in
          if name = prefix && uniq (`Mod, name) then
            try
              let path, md, attrs = Type_utils.lookup_module (Longident.Lident name) env in
              make_candidate ~prefix_path:(Some prefix) ~exact:true ~path name
                 (`Mod md) ~attrs
              :: candidates
            with Not_found ->
              default :: candidates
          else if String.is_prefixed ~by:prefix name && uniq (`Mod,name) then
            default :: candidates
          else
            candidates
      )
    | _ -> find ~is_label (String.concat ~sep:"." @@ Longident.flatten prefix)
  with Not_found -> []

(* Propose completion from a particular node *)
let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix =
  function
  | [] -> []
  | (env, node) :: branch ->
    match node with
    | Method_call (obj,_,_) -> complete_methods ~env ~prefix obj
    | Pattern    { Typedtree.pat_desc = Typedtree.Tpat_record _ ; pat_type = t ; _ }
    | Expression { Typedtree.exp_desc = Typedtree.Texp_record _ ; exp_type = t ; _ } ->
      let is_label =
        try match Types.get_desc t with
          | Types.Tconstr (p, _, _) ->
            (match (Env.find_type p env).Types.type_kind with
             | Types.Type_record (labels, _) ->
               `Declaration (t, labels)
             | _ -> `Maybe)
          | _ -> `Maybe
        with _ -> `Maybe
      in
      let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in
      complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label
        buffer (env,node) branch
    | Record_field (parent, lbl, _) ->
      let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in
      let snap = Btype.snapshot () in
      let is_label = match lbl.Types.lbl_all with
        | [||] ->
          begin match
              let ty = match parent with
                | `Expression e -> e.Typedtree.exp_type
                | `Pattern p -> p.Typedtree.pat_type
              in
              let decl = Ctype.extract_concrete_typedecl env ty in
              (ty, decl)
            with
            | (ty, Typedecl (p, _, decl)) ->
              begin try
                let lbls = Datarepr.labels_of_type p decl in
                let labels = List.map lbls ~f:(fun (_,lbl) ->
                    try
                      let _, lbl_arg, lbl_res = Ctype.instance_label false lbl in
                      begin try
                          Ctype.unify_var env ty lbl_res;
                        with _ -> ()
                      end;
                      (* FIXME: the two subst can lose some sharing between types *)
                      let lbl_res = Subst.type_expr Subst.identity lbl_res in
                      let lbl_arg = Subst.type_expr Subst.identity lbl_arg in
                      {lbl with Types. lbl_res; lbl_arg}
                    with _ -> lbl
                  ) in
                `Description labels
              with _ ->
                match decl.Types.type_kind with
                | Types.Type_record (lbls, _) ->
                  `Declaration (ty, lbls)
                | _ -> `Maybe
                end
            | _ | exception _ -> `Maybe
          end
        | lbls ->
          `Description (Array.to_list lbls)
      in
      let result =
        complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix ~is_label
          buffer (env, node) branch
      in
      Btype.backtrack snap;
      result
    | _ ->
      let prefix, is_label = Longident.(keep_suffix @@ parse prefix) in
      complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix buffer
        ~is_label:(if is_label then `Maybe else `No)
        (env, node) branch

let expand_prefix ~global_modules ?(kinds=[]) env prefix =
  Env.with_cmis @@ fun () ->
  let lidents, last =
    let ts = Expansion.explore ~global_modules env in
    Expansion.get_lidents ts prefix
  in
  let validate' =
    let last = Expansion.spell_index last in
    fun s -> Expansion.spell_match last s
  in
  let validate _ _ s = validate' s in
  let kinds = match kinds with
    | [] -> default_kinds
    | kinds -> (kinds : kind list :> kinds)
  in
  let process_prefix_path prefix_path =
    let candidates =
      let aux compl kind =
        get_candidates ?prefix_path ~prefix:"" kind ~validate env [] :: compl in
      List.fold_left ~f:aux kinds ~init:[]
    in
    match prefix_path with
    | None ->
      let f name =
        if not (validate' name) then None else
          Some (item_for_global_module name)
      in
      candidates @ [List.filter_map global_modules ~f]
      |> List.flatten
    | Some lident ->
      let lident = Longident.flatten lident in
      let lident = String.concat ~sep:"." lident ^ "." in
      List.concat_map candidates ~f:(List.map ~f:(fun c ->
          { c with name = lident ^ Misc_utils.parenthesize_name c.name }))
  in
  List.concat_map ~f:process_prefix_path lidents

open Typedtree

let labels_of_application ~prefix = function
  | {exp_desc = Texp_apply (f, args); exp_env; _} ->
    let rec labels t =
      match Types.get_desc t with
      | Types.Tarrow (label, lhs, rhs, _) ->
        (label, lhs) :: labels rhs
      | _ ->
        let t' = Ctype.full_expand ~may_forget_scope:true exp_env t in
        if Types.TransientTypeOps.equal
          (Types.Transient_expr.repr t)
          (Types.Transient_expr.repr t')
        then
          []
        else
          labels t'
    in
    let labels = labels f.exp_type in
    let is_application_of label (label',expr) =
      match expr with
      | Some {exp_loc = {Location. loc_ghost; loc_start; loc_end}; _} ->
        label = label'
        && (Btype.prefixed_label_name label <> prefix)
        && not loc_ghost
        && not (loc_start = loc_end)
      | None -> false
    in
    List.filter_map ~f:(fun (label, ty) ->
        match label with
        | Asttypes.Nolabel -> None
        | label when List.exists ~f:(is_application_of label) args -> None
        | Asttypes.Labelled str -> Some ("~" ^ str, ty)
        | Asttypes.Optional str ->
          let ty = match Types.get_desc ty with
            | Types.Tconstr (path, [ty], _)
              when Path.same path Predef.path_option -> ty
            | _ -> ty
          in
          Some ("?" ^ str, ty)
      ) labels
  | _ -> []


let application_context ~prefix path =
  let module Printtyp = Type_utils.Printtyp in
  let target_type = ref (
      match snd (List.hd path) with
      | Expression { exp_type = ty ; _ }
      | Pattern    { pat_type = ty ; _ } -> Some ty
      | _ -> None
    )
  in
  let context = match path with
    | (_, Expression earg) ::
      (_, Expression ({ exp_desc = Texp_apply (efun, _); _ } as app)) :: _
      when earg != efun ->
      (* Type variables shared across arguments should all be
         printed with the same name.
         [Printtyp.type_scheme] ensure that a name is unique within a given
         type, but not across different invocations.
         [reset] followed by calls to [mark_loops] and [type_sch] provide
         that *)
      Printtyp.reset ();
      let pr t =
        let ppf, to_string = Format.to_string () in
        Printtyp.shared_type_scheme ppf t;
        to_string ()
      in
      (* Special case for optional arguments applied with ~,
         get the argument wrapped inside Some _ *)
      let earg =
        match Mbrowse.optional_label_sugar earg.exp_desc with
        | None -> earg
        | Some earg ->
          target_type := Some earg.exp_type;
          earg
      in
      let labels = labels_of_application ~prefix app in
      `Application { argument_type = pr earg.exp_type;
                     labels = List.map ~f:(fun (lbl,ty) -> lbl, pr ty) labels;
                   }
    | _ -> `Unknown
  in
  !target_type, context
