diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 3b84ca6c6..cb07e2498 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -77,7 +77,7 @@ jobs: - name: Check that the changes are correctly formatted - if: matrix.os == 'none' + if: matrix.os == 'ubuntu-latest' run: | - opam install ocamlformat.0.27.0 + opam install ocamlformat.0.28.1 opam exec -- dune build @fmt diff --git a/.ocamlformat b/.ocamlformat index 409672b79..07d9993f1 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.27.0 +version=0.28.1 disable=false break-cases=fit-or-vertical diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml index 9cd260414..23bb3c7ed 100644 --- a/src/analysis/ast_iterators.ml +++ b/src/analysis/ast_iterators.ml @@ -147,20 +147,18 @@ let build_uid_to_locs_tbl ~(local_defs : Mtyper.typedtree) () = Types.Uid.Tbl.create 64 in let iter = iter_on_defs ~uid_to_locs_tbl in - begin - match local_defs with - | `Interface sign -> iter.signature iter sign - | `Implementation str -> iter.structure iter str + begin match local_defs with + | `Interface sign -> iter.signature iter sign + | `Implementation str -> iter.structure iter str end; uid_to_locs_tbl let iter_on_usages ~f (local_defs : Mtyper.typedtree) = let occ_iter = Cmt_format.iter_on_occurrences ~f in let iter = iter_only_visible occ_iter in - begin - match local_defs with - | `Interface signature -> iter.signature iter signature - | `Implementation structure -> iter.structure iter structure + begin match local_defs with + | `Interface signature -> iter.signature iter signature + | `Implementation structure -> iter.structure iter structure end let iterator_on_usages ~f = diff --git a/src/analysis/browse_misc.ml b/src/analysis/browse_misc.ml index fb7c5d7e0..322f30948 100644 --- a/src/analysis/browse_misc.ml +++ b/src/analysis/browse_misc.ml @@ -41,7 +41,7 @@ let print_constructor c = let desc = Tarrow ( Ast_helper.no_label, - dummy_type_scheme (Ttuple (List.map ~f:(fun a -> None, a) args)), + dummy_type_scheme (Ttuple (List.map ~f:(fun a -> (None, a)) args)), c.cstr_res, commu_ok ) in @@ -76,11 +76,11 @@ let signature_of_env ?(ignore_extensions = true) env = | Env_type (_, i, t) -> Some (Sig_type (i, t, Trec_not, Exported)) (* Texp_first == bluff, FIXME *) | Env_extension (_, i, e) -> begin - match e.ext_type_path with - | Path.Pident id when Ident.name id = "exn" -> - Some (Sig_typext (i, e, Text_exception, Exported)) - | _ -> Some (Sig_typext (i, e, Text_first, Exported)) - end + match e.ext_type_path with + | Path.Pident id when Ident.name id = "exn" -> + Some (Sig_typext (i, e, Text_exception, Exported)) + | _ -> Some (Sig_typext (i, e, Text_first, Exported)) + end | Env_module (_, i, pr, m) -> Some (Sig_module (i, pr, m, Trec_not, Exported)) | Env_modtype (_, i, m) -> Some (Sig_modtype (i, m, Exported)) @@ -141,7 +141,7 @@ let dump_browse node = `List (append Env.empty node []) let annotate_tail_calls (ts : Mbrowse.t) : - (Env.t * Browse_raw.node * Query_protocol.is_tail_position) list = + (Env.t * Browse_raw.node * Query_protocol.is_tail_position) list = let is_one_of candidates node = List.mem node ~set:candidates in let find_entry_points candidates (env, node) = (Tail_analysis.entry_points node, (env, node, is_one_of candidates node)) @@ -155,9 +155,9 @@ let annotate_tail_calls (ts : Mbrowse.t) : let _, tail_positions = List.fold_n_map entry_points ~f:propagate ~init:[] in List.map ~f:(fun (env, node, tail) -> - ( env, - node, - if not tail then `No - else if Tail_analysis.is_call node then `Tail_call - else `Tail_position )) + ( env, + node, + if not tail then `No + else if Tail_analysis.is_call node then `Tail_call + else `Tail_position )) tail_positions diff --git a/src/analysis/completion.ml b/src/analysis/completion.ml index 40466b34c..a7ba83224 100644 --- a/src/analysis/completion.ml +++ b/src/analysis/completion.ml @@ -61,12 +61,12 @@ let raw_info_printer : raw_info -> _ = function | `Type_scheme te -> `Print (Out_type (Type_utils.Printtyp.tree_of_typ_scheme te)) | `Variant (label, arg) -> begin - match arg with - | None -> `String label - | Some te -> - `Concat - (label ^ " of ", Out_type (Type_utils.Printtyp.tree_of_typ_scheme te)) - end + match arg with + | None -> `String label + | Some te -> + `Concat + (label ^ " of ", Out_type (Type_utils.Printtyp.tree_of_typ_scheme te)) + end (* List methods of an object. Code taken from [uTop](https://github.com/diml/utop @@ -82,11 +82,11 @@ let rec 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 + 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 @@ -175,16 +175,16 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty = 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 + 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)) @@ -214,22 +214,21 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty = | 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 -> Shape.Sig_component_kind.Value - | `Type -> Type - | _ -> assert false - in - begin - match get_doc (`Completion_entry (namespace, p, loc)) with - | `Found str -> `String str - | _ -> `None - | exception _ -> `None - end - | _, _ -> `None) + match (path, loc) with + | Some p, Some loc -> + let namespace = + (* FIXME: that's just terrible *) + match kind with + | `Value -> Shape.Sig_component_kind.Value + | `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 } @@ -279,11 +278,10 @@ let fold_sumtype_constructors ~env ~init ~f t = 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 + 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 @@ -393,12 +391,12 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env 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) + 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 { cstr_res; _ } = type_check cstr_res in @@ -414,46 +412,44 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env 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 + 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) + 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) + 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) + 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 -> - log ~title:"get_candidate" "Labels for prefix=%s prefix_path=%a" - prefix + | `Labels -> ( + log ~title:"get_candidate" "Labels for prefix=%s prefix_path=%a" prefix Logger.fmt (fun fmt -> Format.pp_print_option Pprintast.longident fmt prefix_path); let consider_label ({ lbl_name = name; _ } as l) candidates = @@ -481,7 +477,7 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env in match inlined_record_labels with | Some candidates -> candidates - | None -> Env.fold_labels consider_label prefix_path env [] + | None -> Env.fold_labels consider_label prefix_path env []) in let of_kind_group = function | #Query_protocol.Compl.kind as k -> of_kind k @@ -627,7 +623,8 @@ let complete_prefix ?get_doc ?target_type ?(kinds = []) ~keywords ~prefix in try match prefix with - | Longident.Ldot ({txt=prefix_path;_}, prefix) -> find ~prefix_path ~is_label prefix.txt + | Longident.Ldot ({ txt = prefix_path; _ }, prefix) -> + find ~prefix_path ~is_label prefix.txt | Longident.Lident prefix -> (* Regular completion *) let compl = find ~is_label prefix in @@ -649,28 +646,28 @@ let complete_prefix ?get_doc ?target_type ?(kinds = []) ~keywords ~prefix (* 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) + 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 -> [] @@ -679,83 +676,83 @@ let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix = function | [] -> [] | (env, node) :: branch -> ( - log ~title:"branch_complete" "Leaf node: %a" Mbrowse.print_node node; - 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; _ } -> - log ~title:"branch_complete" "Record"; - 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 + log ~title:"branch_complete" "Leaf node: %a" Mbrowse.print_node node; + 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; _ } -> + log ~title:"branch_complete" "Record"; + 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.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 ~fixed: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 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 - | Record_field (parent, lbl, _) -> - let prefix, _is_label = Longident.(keep_suffix @@ parse prefix) in - let snap = Btype.snapshot () in - let is_label = - match lbl.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 ~fixed: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 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 - log ~title:"branch_complete" "Common case, prefix = %a, is_label = %b" - Logger.fmt (Fun.flip Pprintast.longident prefix) - is_label; - complete_prefix ?get_doc ?target_type ?kinds ~keywords ~prefix buffer - ~is_label:(if is_label then `Maybe else `No) - (env, node) branch) + in + Btype.backtrack snap; + result + | _ -> + let prefix, is_label = Longident.(keep_suffix @@ parse prefix) in + log ~title:"branch_complete" "Common case, prefix = %a, is_label = %b" + Logger.fmt + (Fun.flip Pprintast.longident prefix) + is_label; + 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 () -> @@ -825,18 +822,18 @@ let labels_of_application ~prefix = function 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)) + 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 | _ -> [] @@ -845,9 +842,9 @@ let application_context ~prefix path = let target_type = ref (match snd (List.hd path) with - | Expression { exp_type = ty; _ } | Pattern { pat_type = ty; _ } -> - Some ty - | _ -> None) + | Expression { exp_type = ty; _ } | Pattern { pat_type = ty; _ } -> + Some ty + | _ -> None) in let context = match path with diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli index bc588a221..c26eddd7c 100644 --- a/src/analysis/completion.mli +++ b/src/analysis/completion.mli @@ -52,7 +52,7 @@ val branch_complete : Mconfig.t -> ?get_doc: ([> `Completion_entry of Env_lookup.Namespace.t * Path.t * Location.t ] -> - [> `Found of string ]) -> + [> `Found of string ]) -> ?target_type:Types.type_expr -> ?kinds:Compl.kind list -> keywords:string list -> diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index da2cf524a..9175dda3b 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -13,19 +13,19 @@ exception No_constraint let () = Location.register_error_of_exn (function - | Not_a_hole -> Some (Location.error "Construct only works on holes.") - | Modtype_not_found (Modtype, s) -> - let txt = Format.sprintf "Module type not found: %s" s in - Some (Location.error txt) - | Modtype_not_found (Mod, s) -> - let txt = Format.sprintf "Module not found: %s" s in - Some (Location.error txt) - | No_constraint -> - Some - (Location.error - "Could not find a module type to construct from. Check that you \ - used a correct constraint.") - | _ -> None) + | Not_a_hole -> Some (Location.error "Construct only works on holes.") + | Modtype_not_found (Modtype, s) -> + let txt = Format.sprintf "Module type not found: %s" s in + Some (Location.error txt) + | Modtype_not_found (Mod, s) -> + let txt = Format.sprintf "Module not found: %s" s in + Some (Location.error txt) + | No_constraint -> + Some + (Location.error + "Could not find a module type to construct from. Check that you \ + used a correct constraint.") + | _ -> None) module Util = struct open Misc_utils.Path open Types @@ -121,10 +121,10 @@ module Util = struct Btype.backtrack snap; Some params | None -> begin - match type_expr.desc with - | Tarrow (arg_label, _, te, _) -> check_type te (arg_label :: params) - | _ -> None - end + match type_expr.desc with + | Tarrow (arg_label, _, te, _) -> check_type te (arg_label :: params) + | _ -> None + end in (* TODO we should probably sort the results better *) match (is_in_stdlib path, check_type value_description.val_type []) with @@ -138,12 +138,12 @@ module Util = struct let init = fold_values None Path.Map.empty in Env.fold_modules (fun _name path _module_decl acc -> - if (not (is_in_stdlib path)) && not (is_opened env path) then - (* We ignore opened modules. That means that is a value of an opened + if (not (is_in_stdlib path)) && not (is_opened env path) then + (* We ignore opened modules. That means that is a value of an opened module has been shadowed we won't suggest the one in the opened module. *) - fold_values (Some (Untypeast.lident_of_path path)) acc - else acc) + fold_values (Some (Untypeast.lident_of_path path)) acc + else acc) None env init (** The idents_table is used to keep track of already used names when @@ -208,15 +208,15 @@ module Gen = struct let open Ast_helper in function | Mty_ident path -> begin - try - let m = Env.find_modtype path env in - match m.mtd_type with - | Some t -> module_ env t - | None -> raise Not_found - with Not_found -> - let name = Ident.name (Path.head path) in - raise (Modtype_not_found (Modtype, name)) - end + try + let m = Env.find_modtype path env in + match m.mtd_type with + | Some t -> module_ env t + | None -> raise Not_found + with Not_found -> + let name = Ident.name (Path.head path) in + raise (Modtype_not_found (Modtype, name)) + end | Mty_signature sig_items -> let env = Env.add_signature sig_items env in Mod.structure @@ structure env sig_items @@ -231,13 +231,13 @@ module Gen = struct in Mod.functor_ param @@ module_ env out | Mty_alias path -> begin - try - let m = Env.find_module path env in - module_ env m.md_type - with Not_found -> - let name = Ident.name (Path.head path) in - raise (Modtype_not_found (Mod, name)) - end + try + let m = Env.find_module path env in + module_ env m.md_type + with Not_found -> + let name = Ident.name (Path.head path) in + raise (Modtype_not_found (Mod, name)) + end | Mty_for_hole -> Mod.hole () and structure_item env = @@ -274,8 +274,8 @@ module Gen = struct in Str.type_extension @@ Ast_helper.Te.mk ~attrs:ext_constructor.ext_attributes ~params:[] - ~priv:ext_constructor.ext_private lid - [ Ptyp_of_type.extension_constructor id ext_constructor ] + ~priv:ext_constructor.ext_private lid + [ Ptyp_of_type.extension_constructor id ext_constructor ] | Sig_class_type (id, _class_type_decl, _, _) -> let str = Format.asprintf @@ -295,9 +295,9 @@ module Gen = struct and structure env (items : Types.signature_item list) = List.map (Ptyp_of_type.group_items items) ~f:(function - | Ptyp_of_type.Item item -> structure_item env item - | Ptyp_of_type.Type (rec_flag, type_decls) -> - Ast_helper.Str.type_ rec_flag type_decls) + | Ptyp_of_type.Item item -> structure_item env item + | Ptyp_of_type.Type (rec_flag, type_decls) -> + Ast_helper.Str.type_ rec_flag type_decls) (* [expression values_scope ~depth env ty] generates a list of PAST expressions that could fill a hole of type [ty] in the environment [env]. @@ -330,12 +330,12 @@ module Gen = struct let i = Hashtbl.find idents_table n + 1 in make_i n i with Not_found -> ( - try - let _ = Env.find_value (Path.Pident id) env in - make_i n 0 - with Not_found -> - Hashtbl.add idents_table n 0; - n) + try + let _ = Env.find_value (Path.Pident id) env in + make_i n 0 + with Not_found -> + Hashtbl.add idents_table n 0; + n) in fun env label ty -> let open Asttypes in @@ -350,12 +350,12 @@ module Gen = struct (* Pun for labelled arguments *) (make_param label (Ast_helper.Pat.var (Location.mknoloc s)), s) | Nolabel -> begin - match get_desc ty with - | Tconstr (path, _, _) -> - let name = uniq_name env (Path.last path) in - (make_param label (Ast_helper.Pat.var (Location.mknoloc name)), name) - | _ -> (make_param label (Ast_helper.Pat.any ()), "_") - end + match get_desc ty with + | Tconstr (path, _, _) -> + let name = uniq_name env (Path.last path) in + (make_param label (Ast_helper.Pat.var (Location.mknoloc name)), name) + | _ -> (make_param label (Ast_helper.Pat.any ()), "_") + end in let constructor env type_expr path constrs = @@ -379,9 +379,10 @@ module Gen = struct let args_combinations = Util.combinations args in let exps = List.map args_combinations ~f:(function - | [] -> None - | [ e ] -> Some e - | l -> Some (Ast_helper.Exp.tuple (List.map ~f:(fun l -> None, l) l))) + | [] -> None + | [ e ] -> Some e + | l -> + Some (Ast_helper.Exp.tuple (List.map ~f:(fun l -> (None, l)) l))) in Btype.backtrack snap; List.filter_map exps ~f:(fun exp -> @@ -395,7 +396,7 @@ module Gen = struct else ( log ~title:"constructor" "%s's type is not unifiable with %a" cstr_descr.Data_types.cstr_name Logger.fmt (fun fmt -> - Printtyp.type_expr fmt type_expr); + Printtyp.type_expr fmt type_expr); None)) | None -> [] in @@ -410,10 +411,10 @@ module Gen = struct let fields = List.filter ~f:(fun (_lbl, row_field) -> - match row_field_repr row_field with - | Rpresent _ | Reither (true, [], _) | Reither (false, [ _ ], _) -> - true - | _ -> false) + match row_field_repr row_field with + | Rpresent _ | Reither (true, [], _) | Reither (false, [ _ ], _) -> + true + | _ -> false) (row_fields row_desc) (* [row_fields] are ordered inversly to a source code declaration. We reverse it to match it and provide better UX *) @@ -424,9 +425,9 @@ module Gen = struct | row_descrs -> List.map row_descrs ~f:(fun (lbl, row_field) -> (match row_field_repr row_field with - | Reither (false, [ ty ], _) | Rpresent (Some ty) -> - List.map ~f:(fun s -> Some s) (exp_or_hole env ty) - | _ -> [ None ]) + | Reither (false, [ ty ], _) | Rpresent (Some ty) -> + List.map ~f:(fun s -> Some s) (exp_or_hole env ty) + | _ -> [ None ]) |> List.map ~f:(fun e -> Ast_helper.Exp.variant lbl e)) |> List.flatten |> List.rev in @@ -477,16 +478,16 @@ module Gen = struct let exps = exp_or_hole env texp in List.map exps ~f:Ast_helper.Exp.lazy_ | Tconstr (path, _params, _) -> begin - try - (* If this is a "basic" type we propose a default value *) - [ Hashtbl.find Util.predef_types path ] - with Not_found -> ( - let def = Env.find_type_descrs path env in - match def with - | Type_variant (constrs, _) -> constructor env rtyp path constrs - | Type_record (labels, _) -> record env rtyp path labels - | Type_abstract _ | Type_open -> []) - end + try + (* If this is a "basic" type we propose a default value *) + [ Hashtbl.find Util.predef_types path ] + with Not_found -> ( + let def = Env.find_type_descrs path env in + match def with + | Type_variant (constrs, _) -> constructor env rtyp path constrs + | Type_record (labels, _) -> record env rtyp path labels + | Type_abstract _ | Type_open -> []) + end | Tarrow _ -> let rec left_types acc env ty = match get_desc ty with @@ -513,25 +514,25 @@ module Gen = struct | Ttuple types -> let choices = List.map types ~f:(fun (label, t) -> - List.map ~f:(fun expr -> label, expr) (exp_or_hole env t)) + List.map ~f:(fun expr -> (label, expr)) (exp_or_hole env t)) |> Util.combinations in List.map choices ~f:Ast_helper.Exp.tuple | Tvariant row_desc -> variant env rtyp row_desc | Tpackage ({ pack_path; _ } as pack) -> begin - let open Ast_helper in - try - let ty = Typemod.modtype_of_package env Location.none pack in - let ast = - Exp.constraint_ - (Exp.pack (module_ env ty) None) - (Ptyp_of_type.core_type typ) - in - [ ast ] - with Typemod.Error _ -> - let name = Ident.name (Path.head pack_path) in - raise (Modtype_not_found (Modtype, name)) - end + let open Ast_helper in + try + let ty = Typemod.modtype_of_package env Location.none pack in + let ast = + Exp.constraint_ + (Exp.pack (module_ env ty) None) + (Ptyp_of_type.core_type typ) + in + [ ast ] + with Typemod.Error _ -> + let name = Ident.name (Path.head pack_path) in + raise (Modtype_not_found (Modtype, name)) + end | Tobject (fields, _) -> let rec aux acc fields = match get_desc fields with @@ -550,8 +551,8 @@ module Gen = struct | _ -> failwith @@ Format.asprintf - "Unexpected type constructor in fields list: %a" - Printtyp.type_expr fields + "Unexpected type constructor in fields list: %a" + Printtyp.type_expr fields in let all_fields = aux [] fields |> Util.combinations in List.map all_fields ~f:(fun fields -> diff --git a/src/analysis/context.ml b/src/analysis/context.ml index c7d987059..2c4db2a53 100644 --- a/src/analysis/context.ml +++ b/src/analysis/context.ml @@ -86,7 +86,7 @@ let inspect_pattern (type a) ~cursor ~lid (p : a Typedtree.general_pattern) = None | Tpat_construct (lid_loc, cd, _, _) when cursor_on_longident_end ~cursor ~lid_loc cd.cstr_name - && Longident.last lid = Longident.last lid_loc.txt -> + && Longident.last lid = Longident.last lid_loc.txt -> (* Assumption: if [Browse.enclosing] stopped on this node and not on the subpattern, then it must mean that the cursor is on the constructor itself. *) @@ -127,26 +127,26 @@ let inspect_browse_tree ~cursor lid browse : t option = cursor; Some Unknown | enclosings -> ( - let open Browse_raw in - let node = Browse_tree.of_browse enclosings in - log ~title:"inspect_context" "current enclosing node is: %s" - (string_of_node node.Browse_tree.t_node); - match node.Browse_tree.t_node with - | Pattern p -> inspect_pattern ~cursor ~lid p - | Value_description _ - | Type_declaration _ - | Extension_constructor _ - | Module_binding_name _ - | Module_declaration_name _ - | Label_declaration _ - | Constructor_declaration _ -> None - | Module_expr _ | Open_description _ -> Some Module_path - | Module_type _ -> Some Module_type - | Core_type { ctyp_desc = Ttyp_package _; _ } -> Some Module_type - | Core_type _ -> Some Type - | Record_field (_, lbl, _) when Longident.last lid = lbl.lbl_name -> - (* if we stopped here, then we're on the label itself, and whether or + let open Browse_raw in + let node = Browse_tree.of_browse enclosings in + log ~title:"inspect_context" "current enclosing node is: %s" + (string_of_node node.Browse_tree.t_node); + match node.Browse_tree.t_node with + | Pattern p -> inspect_pattern ~cursor ~lid p + | Value_description _ + | Type_declaration _ + | Extension_constructor _ + | Module_binding_name _ + | Module_declaration_name _ + | Label_declaration _ + | Constructor_declaration _ -> None + | Module_expr _ | Open_description _ -> Some Module_path + | Module_type _ -> Some Module_type + | Core_type { ctyp_desc = Ttyp_package _; _ } -> Some Module_type + | Core_type _ -> Some Type + | Record_field (_, lbl, _) when Longident.last lid = lbl.lbl_name -> + (* if we stopped here, then we're on the label itself, and whether or not punning is happening is not important *) - Some (Label lbl) - | Expression e -> Some (inspect_expression ~cursor ~lid e) - | _ -> Some Unknown) + Some (Label lbl) + | Expression e -> Some (inspect_expression ~cursor ~lid e) + | _ -> Some Unknown) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index 5f769a037..36691b077 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -39,12 +39,12 @@ let { Logger.log } = Logger.for_section "destruct" let () = Location.register_error_of_exn (function - | Not_allowed s -> Some (Location.error ("Destruct not allowed on " ^ s)) - | Useless_refine -> Some (Location.error "Cannot refine an useless branch") - | Nothing_to_do -> Some (Location.error "Nothing to do") - | Ill_typed -> - Some (Location.error "The node on which destruct was called is ill-typed") - | _ -> None) + | Not_allowed s -> Some (Location.error ("Destruct not allowed on " ^ s)) + | Useless_refine -> Some (Location.error "Cannot refine an useless branch") + | Nothing_to_do -> Some (Location.error "Nothing to do") + | Ill_typed -> + Some (Location.error "The node on which destruct was called is ill-typed") + | _ -> None) let mk_id s = Location.mknoloc (Longident.Lident s) let mk_var s = Location.mknoloc s @@ -94,68 +94,68 @@ let rec gen_patterns ?(recurse = true) env type_expr = | Tpackage _ -> raise (Not_allowed "modules") | Ttuple lst -> let patterns = Patterns.omega_list lst in - let patterns = List.map ~f:(fun p -> None, p) patterns in + let patterns = List.map ~f:(fun p -> (None, p)) patterns in [ Tast_helper.Pat.tuple env type_expr patterns ] | Tconstr (path, _params, _) -> begin - match Env.find_type_descrs path env with - | Type_record (labels, _) -> - let lst = - List.map labels ~f:(fun lbl_descr -> - let lidloc = mk_id lbl_descr.Data_types.lbl_name in - ( lidloc, - lbl_descr, - Tast_helper.Pat.var Uid.internal_not_actually_unique env type_expr - (mk_var lbl_descr.lbl_name) )) - in - [ Tast_helper.Pat.record env type_expr lst Asttypes.Closed ] - | Type_variant (constructors, _) -> - let prefix = - let path = Out_type.shorten_type_path env path in - fun name -> - let env_check = Env.find_constructor_by_name in - Misc_utils.Path.to_shortest_lid ~env ~name ~env_check path - in - let are_types_unifiable typ = - let snap = Btype.snapshot () in - let res = - try - ignore - (let pattern_env = - Ctype.Pattern_env.make env ~equations_scope:0 - ~in_counterexample:true - in - Ctype.unify_gadt pattern_env ~pat:type_expr ~expected:typ); - true - with Ctype.Unify _trace -> false - in - Btype.backtrack snap; - res + match Env.find_type_descrs path env with + | Type_record (labels, _) -> + let lst = + List.map labels ~f:(fun lbl_descr -> + let lidloc = mk_id lbl_descr.Data_types.lbl_name in + ( lidloc, + lbl_descr, + Tast_helper.Pat.var Uid.internal_not_actually_unique env type_expr + (mk_var lbl_descr.lbl_name) )) + in + [ Tast_helper.Pat.record env type_expr lst Asttypes.Closed ] + | Type_variant (constructors, _) -> + let prefix = + let path = Out_type.shorten_type_path env path in + fun name -> + let env_check = Env.find_constructor_by_name in + Misc_utils.Path.to_shortest_lid ~env ~name ~env_check path + in + let are_types_unifiable typ = + let snap = Btype.snapshot () in + let res = + try + ignore + (let pattern_env = + Ctype.Pattern_env.make env ~equations_scope:0 + ~in_counterexample:true + in + Ctype.unify_gadt pattern_env ~pat:type_expr ~expected:typ); + true + with Ctype.Unify _trace -> false in - List.filter_map constructors ~f:(fun cstr_descr -> - if - cstr_descr.Data_types.cstr_generalized - && not (are_types_unifiable cstr_descr.cstr_res) - then ( - log ~title:"gen_patterns" "%a" Logger.fmt (fun fmt -> - Format.fprintf fmt - "Eliminating '%s' branch, its return type is not compatible \ - with the expected type (%a)" - cstr_descr.cstr_name Printtyp.type_expr type_expr); - None) - else - let args = - if cstr_descr.cstr_arity <= 0 then [] - else Patterns.omegas cstr_descr.cstr_arity - in - let lidl = Location.mknoloc (prefix cstr_descr.cstr_name) in - Some - (Tast_helper.Pat.construct env type_expr lidl cstr_descr args None)) - | _ -> - if recurse then from_type_decl env path type_expr - else - raise - (Not_allowed (sprintf "non-destructible type: %s" (Path.last path))) - end + Btype.backtrack snap; + res + in + List.filter_map constructors ~f:(fun cstr_descr -> + if + cstr_descr.Data_types.cstr_generalized + && not (are_types_unifiable cstr_descr.cstr_res) + then ( + log ~title:"gen_patterns" "%a" Logger.fmt (fun fmt -> + Format.fprintf fmt + "Eliminating '%s' branch, its return type is not compatible \ + with the expected type (%a)" + cstr_descr.cstr_name Printtyp.type_expr type_expr); + None) + else + let args = + if cstr_descr.cstr_arity <= 0 then [] + else Patterns.omegas cstr_descr.cstr_arity + in + let lidl = Location.mknoloc (prefix cstr_descr.cstr_name) in + Some + (Tast_helper.Pat.construct env type_expr lidl cstr_descr args None)) + | _ -> + if recurse then from_type_decl env path type_expr + else + raise + (Not_allowed (sprintf "non-destructible type: %s" (Path.last path))) + end | Tvariant row_desc -> List.filter_map (row_fields row_desc) ~f:(fun (lbl, row_field) -> match (lbl, row_field_repr row_field) with @@ -182,105 +182,105 @@ and from_type_decl env path texpr = match tdecl.Types.type_manifest with | Some te -> gen_patterns ~recurse:false env te | None -> ( - try Hashtbl.find Predef_types.tbl path env texpr - with Not_found -> - raise (Not_allowed (sprintf "non-destructible type: %s" (Path.last path))) + try Hashtbl.find Predef_types.tbl path env texpr + with Not_found -> + raise (Not_allowed (sprintf "non-destructible type: %s" (Path.last path))) ) let rec needs_parentheses = function | [] -> false | t :: ts -> ( - match t with - | Structure _ | Structure_item _ | Value_binding _ -> false - | Expression e -> begin - match e.Typedtree.exp_desc with - | Texp_for _ | Texp_while _ -> false - | Texp_let _ - (* We are after the "in" keyword, we need to look at the parent of the + match t with + | Structure _ | Structure_item _ | Value_binding _ -> false + | Expression e -> begin + match e.Typedtree.exp_desc with + | Texp_for _ | Texp_while _ -> false + | Texp_let _ + (* We are after the "in" keyword, we need to look at the parent of the binding. *) - | Texp_function (_, Tfunction_body _) - (* The assumption here is that we're not in a [function ... | ...] + | Texp_function (_, Tfunction_body _) + (* The assumption here is that we're not in a [function ... | ...] situation but either in [fun param] or [let name param]. *) - -> needs_parentheses ts - | _ -> true - end - | _ -> needs_parentheses ts) + -> needs_parentheses ts + | _ -> true + end + | _ -> needs_parentheses ts) let rec get_match = function | [] -> assert false | parent :: parents -> ( - match parent with - | Case _ | Pattern _ -> - (* We are still in the same branch, going up. *) - get_match parents - | Expression m -> ( - match m.Typedtree.exp_desc with - | Typedtree.Texp_match (e, _, _, _) -> (m, e.exp_type) - | Typedtree.Texp_function _ -> ( - let typ = m.exp_type in - (* Function must have arrow type. This arrow type + match parent with + | Case _ | Pattern _ -> + (* We are still in the same branch, going up. *) + get_match parents + | Expression m -> ( + match m.Typedtree.exp_desc with + | Typedtree.Texp_match (e, _, _, _) -> (m, e.exp_type) + | Typedtree.Texp_function _ -> ( + let typ = m.exp_type in + (* Function must have arrow type. This arrow type might be hidden behind type constructors *) - ( m, - match Types.get_desc typ with - | Tarrow (_, te, _, _) -> te - | Tconstr _ -> ( - match - Ctype.full_expand ~may_forget_scope:true m.exp_env typ - |> Types.get_desc - with - | Tarrow (_, te, _, _) -> te - | _ -> assert false) - | _ -> assert false )) - | _ -> - (* We were not in a match *) - let s = Mbrowse.print_node () parent in - raise (Not_allowed s)) + ( m, + match Types.get_desc typ with + | Tarrow (_, te, _, _) -> te + | Tconstr _ -> ( + match + Ctype.full_expand ~may_forget_scope:true m.exp_env typ + |> Types.get_desc + with + | Tarrow (_, te, _, _) -> te + | _ -> assert false) + | _ -> assert false )) | _ -> (* We were not in a match *) let s = Mbrowse.print_node () parent in raise (Not_allowed s)) + | _ -> + (* We were not in a match *) + let s = Mbrowse.print_node () parent in + raise (Not_allowed s)) let collect_every_pattern_for_expression parent = let patterns = Mbrowse.fold_node (fun env node acc -> - match node with - | Pattern _ -> (* Not expected here *) raise Nothing_to_do - | Case _ -> - Mbrowse.fold_node - (fun _env node acc -> - match node with - | Pattern p -> - let ill_typed_pred = - Typedtree. - { f = - (fun p -> - List.memq Msupport.incorrect_attribute - ~set:p.pat_attributes) - } - in - if Typedtree.exists_general_pattern ill_typed_pred p then - raise Ill_typed - else begin - match Typedtree.classify_pattern p with - | Value -> (p : Typedtree.pattern) :: acc - | Computation -> begin - match Typedtree.split_pattern p with - | Some p, _ -> (p : Typedtree.pattern) :: acc - | None, _ -> acc - end + match node with + | Pattern _ -> (* Not expected here *) raise Nothing_to_do + | Case _ -> + Mbrowse.fold_node + (fun _env node acc -> + match node with + | Pattern p -> + let ill_typed_pred = + Typedtree. + { f = + (fun p -> + List.memq Msupport.incorrect_attribute + ~set:p.pat_attributes) + } + in + if Typedtree.exists_general_pattern ill_typed_pred p then + raise Ill_typed + else begin + match Typedtree.classify_pattern p with + | Value -> (p : Typedtree.pattern) :: acc + | Computation -> begin + match Typedtree.split_pattern p with + | Some p, _ -> (p : Typedtree.pattern) :: acc + | None, _ -> acc end - | _ -> acc) - env node acc - | _ -> acc) + end + | _ -> acc) + env node acc + | _ -> acc) Env.empty parent [] in let loc = Mbrowse.fold_node (fun _ node acc -> - let open Location in - let loc = Mbrowse.node_loc node in - if Lexing.compare_pos loc.loc_end acc.loc_end > 0 then loc else acc) + let open Location in + let loc = Mbrowse.node_loc node in + if Lexing.compare_pos loc.loc_end acc.loc_end > 0 then loc else acc) Env.empty parent Location.none in (loc, patterns) @@ -293,36 +293,36 @@ let collect_function_pattern loc param_pattern = let rec get_every_pattern loc = function | [] -> assert false | parent :: parents -> ( - match parent with - | Case _ | Pattern _ -> - (* We are still in the same branch, going up. *) - get_every_pattern loc parents - | Expression { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _); _ } - when Ident.name id = "*type-error*" -> raise Ill_typed - | Expression { exp_desc = Typedtree.Texp_function (params, _body); _ } -> - begin - (* So we need to deal with the case where we're either in the body of a + match parent with + | Case _ | Pattern _ -> + (* We are still in the same branch, going up. *) + get_every_pattern loc parents + | Expression { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _); _ } + when Ident.name id = "*type-error*" -> raise Ill_typed + | Expression { exp_desc = Typedtree.Texp_function (params, _body); _ } -> + begin + (* So we need to deal with the case where we're either in the body of a function, or in a function parameter. *) - match - List.find_some - ~f:(fun param -> - Location_aux.included ~into:param.Typedtree.fp_loc loc) - params - with - | Some pattern -> - (* In parameter case *) - collect_function_pattern loc pattern - | None -> - (* In function body *) - collect_every_pattern_for_expression parent - end - | Expression _ -> - (* We are on the right node *) + match + List.find_some + ~f:(fun param -> + Location_aux.included ~into:param.Typedtree.fp_loc loc) + params + with + | Some pattern -> + (* In parameter case *) + collect_function_pattern loc pattern + | None -> + (* In function body *) collect_every_pattern_for_expression parent - | _ -> - (* We were not in a match *) - let s = Mbrowse.print_node () parent in - raise (Not_allowed s)) + end + | Expression _ -> + (* We are on the right node *) + collect_every_pattern_for_expression parent + | _ -> + (* We were not in a match *) + let s = Mbrowse.print_node () parent in + raise (Not_allowed s)) let rec destructible patt = let open Typedtree in @@ -353,7 +353,7 @@ let filter_pat_attr pat = filter_attr.Ast_mapper.pat filter_attr pat let rec subst_patt initial ~by patt = let f pat = subst_patt initial ~by pat in - let f_label (label, pat) = label, subst_patt initial ~by pat in + let f_label (label, pat) = (label, subst_patt initial ~by pat) in if patt == initial then by else let open Typedtree in @@ -361,7 +361,8 @@ let rec subst_patt initial ~by patt = | Tpat_any | Tpat_var _ | Tpat_constant _ -> patt | Tpat_alias (p, x, y, uid, t) -> { patt with pat_desc = Tpat_alias (f p, x, y, uid, t) } - | Tpat_tuple lst -> { patt with pat_desc = Tpat_tuple (List.map lst ~f:f_label) } + | Tpat_tuple lst -> + { patt with pat_desc = Tpat_tuple (List.map lst ~f:f_label) } | Tpat_construct (lid, cd, lst, lco) -> { patt with pat_desc = Tpat_construct (lid, cd, List.map lst ~f, lco) } | Tpat_variant (lbl, pat_opt, row_desc) -> @@ -373,20 +374,22 @@ let rec subst_patt initial ~by patt = List.map sub ~f:(fun (lid, lbl_descr, patt) -> (lid, lbl_descr, f patt)) in { patt with pat_desc = Tpat_record (sub', flg) } - | Tpat_array (r, lst) -> { patt with pat_desc = Tpat_array (r, List.map lst ~f) } + | Tpat_array (r, lst) -> + { patt with pat_desc = Tpat_array (r, List.map lst ~f) } | Tpat_or (p1, p2, row) -> { patt with pat_desc = Tpat_or (f p1, f p2, row) } | Tpat_lazy p -> { patt with pat_desc = Tpat_lazy (f p) } let rec rm_sub patt sub = let f p = rm_sub p sub in - let f_label (label, p) = label, rm_sub p sub in + let f_label (label, p) = (label, rm_sub p sub) in let open Typedtree in match patt.pat_desc with | Tpat_any | Tpat_var _ | Tpat_constant _ -> patt | Tpat_alias (p, x, y, uid, ty) -> { patt with pat_desc = Tpat_alias (f p, x, y, uid, ty) } - | Tpat_tuple lst -> { patt with pat_desc = Tpat_tuple (List.map lst ~f:f_label) } + | Tpat_tuple lst -> + { patt with pat_desc = Tpat_tuple (List.map lst ~f:f_label) } | Tpat_construct (lid, cd, lst, lco) -> { patt with pat_desc = Tpat_construct (lid, cd, List.map lst ~f, lco) } | Tpat_variant (lbl, pat_opt, row_desc) -> @@ -396,7 +399,8 @@ let rec rm_sub patt sub = List.map sub ~f:(fun (lid, lbl_descr, patt) -> (lid, lbl_descr, f patt)) in { patt with pat_desc = Tpat_record (sub', flg) } - | Tpat_array (r, lst) -> { patt with pat_desc = Tpat_array (r, List.map lst ~f) } + | Tpat_array (r, lst) -> + { patt with pat_desc = Tpat_array (r, List.map lst ~f) } | Tpat_or (p1, p2, row) -> if p1 == sub then p2 else if p2 == sub then p1 @@ -410,7 +414,9 @@ let rec qualify_constructors ~unmangling_tables f pat = match pat.pat_desc with | Tpat_alias (p, id, loc, uid, ty) -> Tpat_alias (qualify_constructors f p, id, loc, uid, ty) - | Tpat_tuple ps -> Tpat_tuple (List.map ps ~f:(fun (label, ty) -> label, qualify_constructors f ty)) + | Tpat_tuple ps -> + Tpat_tuple + (List.map ps ~f:(fun (label, ty) -> (label, qualify_constructors f ty))) | Tpat_record (labels, closed) -> let labels = let open Longident in @@ -421,7 +427,9 @@ let rec qualify_constructors ~unmangling_tables f pat = let _, labels = unmangling_tables in match Hashtbl.find_opt labels lid_name with | Some lbl_des -> - ({ lid with txt = Lident lbl_des.Data_types.lbl_name }, lbl_des, pat) + ( { lid with txt = Lident lbl_des.Data_types.lbl_name }, + lbl_des, + pat ) | None -> (lid, lbl_des, pat)) in let closed = @@ -444,23 +452,23 @@ let rec qualify_constructors ~unmangling_tables f pat = | Some cstr_des -> cstr_des.Data_types.cstr_name | None -> name in - begin - match Types.get_desc pat.pat_type with - | Types.Tconstr (path, _, _) -> - let path = f pat.pat_env path in - let env_check = Env.find_constructor_by_name in - let txt = - Misc_utils.Path.to_shortest_lid ~env:pat.pat_env ~name - ~env_check path - in - { lid with Asttypes.txt } - | _ -> lid + begin match Types.get_desc pat.pat_type with + | Types.Tconstr (path, _, _) -> + let path = f pat.pat_env path in + let env_check = Env.find_constructor_by_name in + let txt = + Misc_utils.Path.to_shortest_lid ~env:pat.pat_env ~name ~env_check + path + in + { lid with Asttypes.txt } + | _ -> lid end | _ -> lid (* already qualified *) in Tpat_construct (lid, cstr_desc, List.map ps ~f:(qualify_constructors f), lco) - | Tpat_array (r, ps) -> Tpat_array (r, List.map ps ~f:(qualify_constructors f)) + | Tpat_array (r, ps) -> + Tpat_array (r, List.map ps ~f:(qualify_constructors f)) | Tpat_or (p1, p2, row_desc) -> Tpat_or (qualify_constructors f p1, qualify_constructors f p2, row_desc) | Tpat_lazy p -> Tpat_lazy (qualify_constructors f p) @@ -476,8 +484,8 @@ let find_branch patterns sub = match patt.pat_desc with | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> false - | Tpat_alias (p, _, _, _, _) | Tpat_variant (_, Some p, _) | Tpat_lazy p -> - is_sub_patt p ~sub + | Tpat_alias (p, _, _, _, _) | Tpat_variant (_, Some p, _) | Tpat_lazy p + -> is_sub_patt p ~sub | Tpat_tuple lst -> List.exists lst ~f:(fun (_, pat) -> is_sub_patt ~sub pat) | Tpat_construct (_, _, lst, _) | Tpat_array (_, lst) -> @@ -500,9 +508,9 @@ let find_field_name_for_punned_field patt = function | Pattern { pat_desc = Tpat_record (fields, _); _ } :: _ -> List.find_opt ~f:(fun (_, _, opat) -> - let ppat_loc = patt.Typedtree.pat_loc - and opat_loc = opat.Typedtree.pat_loc in - Int.equal (Location_aux.compare ppat_loc opat_loc) 0) + let ppat_loc = patt.Typedtree.pat_loc + and opat_loc = opat.Typedtree.pat_loc in + Int.equal (Location_aux.compare ppat_loc opat_loc) 0) fields |> Option.map ~f:(fun (_, label, _) -> label) | _ -> None @@ -538,7 +546,10 @@ module Conv = struct | Tpat_any | Tpat_var _ -> mkpat Ppat_any | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) | Tpat_alias (p, _, _, _, _) -> loop p - | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map ~f:(fun (label, ty) -> label, loop ty) lst, Closed)) + | Tpat_tuple lst -> + mkpat + (Ppat_tuple + (List.map ~f:(fun (label, ty) -> (label, loop ty)) lst, Closed)) | Tpat_construct (cstr_lid, cstr, lst, _) -> let id = fresh cstr.cstr_name in let lid = { cstr_lid with txt = Longident.Lident id } in @@ -547,7 +558,11 @@ module Conv = struct match List.map ~f:loop lst with | [] -> None | [ p ] -> Some ([], p) - | lst -> Some ([], mkpat (Ppat_tuple ((List.map ~f:(fun t -> None, t) lst), Closed))) + | lst -> + Some + ( [], + mkpat + (Ppat_tuple (List.map ~f:(fun t -> (None, t)) lst, Closed)) ) in mkpat (Ppat_construct (lid, arg)) | Tpat_variant (label, p_opt, _row_desc) -> @@ -557,9 +572,9 @@ module Conv = struct let fields = List.map ~f:(fun (_, lbl, p) -> - let id = fresh lbl.Data_types.lbl_name in - Hashtbl.add labels id lbl; - (mknoloc (Longident.Lident id), loop p)) + let id = fresh lbl.Data_types.lbl_name in + Hashtbl.add labels id lbl; + (mknoloc (Longident.Lident id), loop p)) subpatterns in mkpat (Ppat_record (fields, Open)) @@ -585,15 +600,15 @@ let remove_non_applied_optional_args (Parsetree.{ pexp_desc; _ } as base_expr) = let args = List.concat_map ~f:(fun (label, (expr : Parsetree.expression)) -> - match (label, expr.pexp_loc.loc_ghost, expr.pexp_desc) with - | ( Asttypes.Optional _, - true, - Pexp_construct ({ txt = Longident.Lident "None"; _ }, _) ) -> [] - | Asttypes.Optional str, false, exp_desc -> ( - match need_recover_labeled_args exp_desc with - | Some e -> [ (Asttypes.Labelled str, e) ] - | None -> [ (label, expr) ]) - | _ -> [ (label, expr) ]) + match (label, expr.pexp_loc.loc_ghost, expr.pexp_desc) with + | ( Asttypes.Optional _, + true, + Pexp_construct ({ txt = Longident.Lident "None"; _ }, _) ) -> [] + | Asttypes.Optional str, false, exp_desc -> ( + match need_recover_labeled_args exp_desc with + | Some e -> [ (Asttypes.Labelled str, e) ] + | None -> [ (label, expr) ]) + | _ -> [ (label, expr) ]) args in let pexp_desc = Parsetree.Pexp_apply (expr, args) in @@ -690,17 +705,16 @@ let refine_complete_match (type a) parents (patt : a Typedtree.general_pattern) if not (destructible patt) then raise Nothing_to_do else let ty = patt.Typedtree.pat_type in - begin - match gen_patterns patt.Typedtree.pat_env ty with - | [] -> assert false - | [ more_precise_pattern ] -> - (* If only one pattern is generated, then we're only refining the + begin match gen_patterns patt.Typedtree.pat_env ty with + | [] -> assert false + | [ more_precise_pattern ] -> + (* If only one pattern is generated, then we're only refining the current pattern, not generating new branches. *) - refine_current_pattern parents patt config source more_precise_pattern - | sub_patterns -> - (* If more than one pattern is generated, then we're generating new + refine_current_pattern parents patt config source more_precise_pattern + | sub_patterns -> + (* If more than one pattern is generated, then we're generating new branches. *) - refine_and_generate_branches patt config source patterns sub_patterns + refine_and_generate_branches patt config source patterns sub_patterns end let destruct_pattern (type a) (patt : a Typedtree.general_pattern) config source diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml index 9ffe50072..ba887674d 100644 --- a/src/analysis/env_lookup.ml +++ b/src/analysis/env_lookup.ml @@ -68,9 +68,9 @@ let path_and_loc_of_cstr desc _ = match desc.Data_types.cstr_tag with | Cstr_extension (path, _) -> (path, desc.cstr_loc) | _ -> ( - match get_desc desc.cstr_res with - | Tconstr (path, _, _) -> (path, desc.cstr_loc) - | _ -> assert false) + match get_desc desc.cstr_res with + | Tconstr (path, _, _) -> (path, desc.cstr_loc) + | _ -> assert false) let path_and_loc_from_label desc env = let open Types in diff --git a/src/analysis/expansion.ml b/src/analysis/expansion.ml index c42820ee7..33805ccea 100644 --- a/src/analysis/expansion.ml +++ b/src/analysis/expansion.ml @@ -4,7 +4,9 @@ type t = Trie of (string * Longident.t * t list lazy_t) let rec explore_node lident env = let add_module name _ _ l = - let lident = Longident.Ldot (Location.mknoloc lident, Location.mknoloc name) in + let lident = + Longident.Ldot (Location.mknoloc lident, Location.mknoloc name) + in Trie (name, lident, lazy (explore_node lident env)) :: l in Env.fold_modules add_module (Some lident) env [] diff --git a/src/analysis/index_occurrences.ml b/src/analysis/index_occurrences.ml index 03721bb6f..a0c9f0c16 100644 --- a/src/analysis/index_occurrences.ml +++ b/src/analysis/index_occurrences.ml @@ -33,25 +33,24 @@ let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid = let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in let index_decl () = - begin - match decl_of_path_or_lid env namespace path lid.txt with - | (exception _) | None -> - log ~title:"index_buffer" "Declaration not found" - | Some decl -> - log ~title:"index_buffer" "Found declaration: %a" Logger.fmt - (Fun.flip Location.print_loc decl.loc); - add decl.uid lid + begin match decl_of_path_or_lid env namespace path lid.txt with + | (exception _) | None -> + log ~title:"index_buffer" "Declaration not found" + | Some decl -> + log ~title:"index_buffer" "Found declaration: %a" Logger.fmt + (Fun.flip Location.print_loc decl.loc); + add decl.uid lid end in - let reduce_and_store ~namespace lid path = if not_ghost lid then - match Env.shape_of_path ~namespace env path with - | exception Not_found -> () - | path_shape -> - log ~title:"index_buffer" "Shape of path: %a" Logger.fmt - (Fun.flip Shape.print path_shape); - let result = reduce_for_uid env path_shape in - begin - match Locate.uid_of_result ~traverse_aliases:false result with + let reduce_and_store ~namespace lid path = + if not_ghost lid then + match Env.shape_of_path ~namespace env path with + | exception Not_found -> () + | path_shape -> + log ~title:"index_buffer" "Shape of path: %a" Logger.fmt + (Fun.flip Shape.print path_shape); + let result = reduce_for_uid env path_shape in + begin match Locate.uid_of_result ~traverse_aliases:false result with | Some uid, false -> log ~title:"index_buffer" "Found %a (%a) wiht uid %a" Logger.fmt (Fun.flip Pprintast.longident lid.txt) @@ -68,24 +67,22 @@ let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid = | None, _ -> log ~title:"index_buffer" "Reduction failed: missing uid"; index_decl () - end + end in (* Shape reduction can be expensive, but the persistent memoization tables should make these successive reductions fast. *) - let rec index_components namespace lid path = + let rec index_components namespace lid path = let module_ = Shape.Sig_component_kind.Module in - match lid.Location.txt, path with + match (lid.Location.txt, path) with | Longident.Ldot (lid', _), Path.Pdot (path', _) - | Ldot (lid', _), Pextra_ty (Pdot(path', _), Pcstr_ty _)-> + | Ldot (lid', _), Pextra_ty (Pdot (path', _), Pcstr_ty _) -> reduce_and_store ~namespace lid path; index_components module_ lid' path' | Lapply (lid', lid''), Papply (path', path'') - | Lapply (lid', lid''), - Pextra_ty (Papply (path', path''), Pcstr_ty _) -> + | Lapply (lid', lid''), Pextra_ty (Papply (path', path''), Pcstr_ty _) -> index_components module_ lid'' path''; index_components module_ lid' path' - | Longident.Lident _, _ -> - reduce_and_store ~namespace lid path; + | Longident.Lident _, _ -> reduce_and_store ~namespace lid path | _, _ -> () in index_components namespace lid path diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 6aeb10c73..09e2f5caa 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -422,12 +422,13 @@ let find_source ~config loc = log ~title:"find_source" "failed to find %S in source path (fallback = %b)" filename with_fallback; log ~title:"find_source" "looking for %S in %S" (File.name file) dir; - begin - match Utils.find_file_with_path ~config ~with_fallback file [ dir ] with - | Some source -> Found source - | None -> ( - log ~title:"find_source" "Trying to find %S in %S directly" fname dir; - try Found (Misc.find_in_path [ dir ] fname) with _ -> Not_found file) + begin match + Utils.find_file_with_path ~config ~with_fallback file [ dir ] + with + | Some source -> Found source + | None -> ( + log ~title:"find_source" "Trying to find %S in %S directly" fname dir; + try Found (Misc.find_in_path [ dir ] fname) with _ -> Not_found file) end | [ x ] -> Found x | files -> ( @@ -904,10 +905,9 @@ let find_compunit_doc_in_typedtree cmt_infos = | None -> `No_documentation | Some attr -> log ~title:"doc_from_uid" "Found attributes for this uid"; - begin - match find_doc_attribute [ attr ] with - | Some (doc, _) -> `Found_doc (doc |> String.trim) - | None -> `No_documentation + begin match find_doc_attribute [ attr ] with + | Some (doc, _) -> `Found_doc (doc |> String.trim) + | None -> `No_documentation end let doc_of_item_declaration decl = @@ -953,29 +953,27 @@ let find_uid_doc_in_cmt cmt_infos uid = end let doc_from_uid ~config ~loc uid = - begin - match uid with - | (Shape.Uid.Item { comp_unit; _ } | Shape.Uid.Compilation_unit comp_unit) - when Env.get_current_unit_name () <> comp_unit -> - log ~title:"get_doc" - "the doc (%a) you're looking for is in another\n\ - \ compilation unit (%s)" - Logger.fmt - (fun fmt -> Shape.Uid.print fmt uid) - comp_unit; - log ~title:"doc_from_uid" "Loading the cmt for unit %S" comp_unit; - begin - match load_cmt ~config:{ config with ml_or_mli = `MLI } comp_unit with - | Error _ -> `No_documentation - | Ok (_, cmt_infos) -> - log ~title:"doc_from_uid" "Cmt loaded for %s" - (Option.value ~default:"<>" cmt_infos.cmt_sourcefile); - find_uid_doc_in_cmt cmt_infos uid - end - | _ -> - (* Uid based search doesn't works in the current CU since Merlin's parser + begin match uid with + | (Shape.Uid.Item { comp_unit; _ } | Shape.Uid.Compilation_unit comp_unit) + when Env.get_current_unit_name () <> comp_unit -> + log ~title:"get_doc" + "the doc (%a) you're looking for is in another\n\ + \ compilation unit (%s)" + Logger.fmt + (fun fmt -> Shape.Uid.print fmt uid) + comp_unit; + log ~title:"doc_from_uid" "Loading the cmt for unit %S" comp_unit; + begin match load_cmt ~config:{ config with ml_or_mli = `MLI } comp_unit with + | Error _ -> `No_documentation + | Ok (_, cmt_infos) -> + log ~title:"doc_from_uid" "Cmt loaded for %s" + (Option.value ~default:"<>" cmt_infos.cmt_sourcefile); + find_uid_doc_in_cmt cmt_infos uid + end + | _ -> + (* Uid based search doesn't works in the current CU since Merlin's parser does not attach doc comments to the typedtree *) - `Found_loc loc + `Found_loc loc end let doc_from_comment_list ~after_only ~buffer_comments loc = @@ -1022,27 +1020,23 @@ let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos = Logger.fmt (fun fmt -> (Format_doc.compat Path.print) fmt path); let from_path = from_path ~config ~env ~local_defs ~namespace path in - begin - match from_path with - | `Found { uid; location = loc; _ } - | `File_not_found { uid; location = loc; _ } -> - doc_from_uid ~config ~loc uid - | (`Builtin _ | `Not_in_env _ | `Not_found _) as otherwise -> - otherwise + begin match from_path with + | `Found { uid; location = loc; _ } + | `File_not_found { uid; location = loc; _ } -> + doc_from_uid ~config ~loc uid + | (`Builtin _ | `Not_in_env _ | `Not_found _) as otherwise -> otherwise end | `User_input path -> log ~title:"get_doc" "looking for the doc of '%s'" path; - begin - match from_string ~config ~env ~local_defs ~pos path with - | `Found { uid; location = loc; _ } - | `File_not_found { uid; location = loc; _ } -> - doc_from_uid ~config ~loc uid - | `At_origin -> - `Found_loc - { Location.loc_start = pos; loc_end = pos; loc_ghost = true } - | `Missing_labels_namespace -> `No_documentation - | (`Builtin _ | `Not_in_env _ | `Not_found _) as otherwise -> - otherwise + begin match from_string ~config ~env ~local_defs ~pos path with + | `Found { uid; location = loc; _ } + | `File_not_found { uid; location = loc; _ } -> + doc_from_uid ~config ~loc uid + | `At_origin -> + `Found_loc + { Location.loc_start = pos; loc_end = pos; loc_ghost = true } + | `Missing_labels_namespace -> `No_documentation + | (`Builtin _ | `Not_in_env _ | `Not_found _) as otherwise -> otherwise end in match doc_from_uid_result with @@ -1064,12 +1058,11 @@ let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos = Mbrowse.(leaf_node @@ deepest_before loc.Location.loc_start [ browse ]) in let after_only = - begin - match deepest_before with - | Browse_raw.Constructor_declaration _ -> true - (* The remaining `true` cases are currently not reachable *) - | Label_declaration _ | Record_field _ | Row_field _ -> true - | _ -> false + begin match deepest_before with + | Browse_raw.Constructor_declaration _ -> true + (* The remaining `true` cases are currently not reachable *) + | Label_declaration _ | Record_field _ | Row_field _ -> true + | _ -> false end in doc_from_comment_list ~after_only ~buffer_comments:comments loc diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml index 2e1c776a7..18e20f11b 100644 --- a/src/analysis/misc_utils.ml +++ b/src/analysis/misc_utils.ml @@ -75,17 +75,15 @@ let reconstruct_identifier pipeline pos = function then dot else "( " ^ dot ^ ")" in - begin - match path with - | [] -> [] - | base :: tail -> - let f { Location.txt = base; loc = bl } { Location.txt = dot; loc = dl } - = - let loc = Location_aux.union bl dl in - let txt = base ^ "." ^ reify dot in - Location.mkloc txt loc - in - [ List.fold_left tail ~init:base ~f ] + begin match path with + | [] -> [] + | base :: tail -> + let f { Location.txt = base; loc = bl } { Location.txt = dot; loc = dl } = + let loc = Location_aux.union bl dl in + let txt = base ^ "." ^ reify dot in + Location.mkloc txt loc + in + [ List.fold_left tail ~init:base ~f ] end | Some (expr, offset) -> let loc_start = diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 26897ea46..4da56e31f 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -94,8 +94,9 @@ let uid_and_loc_of_node env node = let md = Env.find_module (Pident ident) env in Some (md.md_uid, mb_name.loc) | Pattern - { pat_desc = Tpat_var (_, name, uid) | Tpat_alias (_, _, name, uid, _); _ } - -> Some (uid, name.loc) + { pat_desc = Tpat_var (_, name, uid) | Tpat_alias (_, _, name, uid, _); + _ + } -> Some (uid, name.loc) | Type_declaration { typ_type; typ_name; _ } -> Some (typ_type.type_uid, typ_name.loc) | Label_declaration { ld_uid; ld_name; _ } -> Some (ld_uid, ld_name.loc) @@ -131,20 +132,20 @@ end = struct log ~title:"stat_check" "No stats found for file %S." file; true | Some { size; _ } -> ( - try - let stats = Unix.stat file in - let equal = - (* This is fast but approximative. A better option would be to check + try + let stats = Unix.stat file in + let equal = + (* This is fast but approximative. A better option would be to check [mtime] and then [source_digest] if the times differ. *) - Int.equal stats.st_size size - in - if not equal then - log ~title:"stat_check" - "File %s has been modified since the index was built." file; - equal - with Unix.Unix_error _ -> - log ~title:"stat_check" "Could not stat file %S" file; - false) + Int.equal stats.st_size size + in + if not equal then + log ~title:"stat_check" + "File %s has been modified since the index was built." file; + equal + with Unix.Unix_error _ -> + log ~title:"stat_check" "Could not stat file %S" file; + false) let check t ~file = let cache_and_return b = @@ -159,13 +160,13 @@ end let get_buffer_locs result uid = Stamped_hashtable.fold (fun (uid', loc) () acc -> - if Shape.Uid.equal uid uid' then - Lid_set.add (Index_format.Lid.of_lid loc) acc - else acc) + if Shape.Uid.equal uid uid' then + Lid_set.add (Index_format.Lid.of_lid loc) acc + else acc) (Mtyper.get_index result) Lid_set.empty let get_external_locs ~(config : Mconfig.t) ~current_buffer_path uid : - (Occurrence_set.t * Std.String.Set.t) list = + (Occurrence_set.t * Std.String.Set.t) list = let title = "get_external_locs" in List.filter_map config.merlin.index_files ~f:(fun index_file -> log ~title "Lookin for occurrences of %a in index %s" Logger.fmt @@ -219,14 +220,14 @@ let lookup_related_uids_in_indexes ~(config : Mconfig.t) uid = let related_uids = List.fold_left ~init:(Uid_map.empty ()) config.merlin.index_files ~f:(fun acc index_file -> - try - let index = Index_cache.read index_file in - Uid_map.union - (fun _ a b -> Some (Union_find.union a b)) - index.related_uids acc - with Index_format.Not_an_index _ | Sys_error _ -> - log ~title "Could not load index %s" index_file; - acc) + try + let index = Index_cache.read index_file in + Uid_map.union + (fun _ a b -> Some (Union_find.union a b)) + index.related_uids acc + with Index_format.Not_an_index _ | Sys_error _ -> + log ~title "Could not load index %s" index_file; + acc) in Uid_map.find_opt uid related_uids |> Option.value_map ~default:[] ~f:(fun x -> @@ -243,14 +244,14 @@ let find_linked_uids ~config ~scope ~name uid = Locate.lookup_uid_decl ~config uid |> Option.bind ~f:(Typedtree_utils.location_of_declaration ~uid) |> Option.value_map - ~f:(fun { Location.txt; _ } -> - let result = String.equal name txt in - if not result then - log ~title "Found clashing idents %S <> %S. Ignoring UID %a." - name txt Logger.fmt - (Fun.flip Shape.Uid.print uid); - result) - ~default:false + ~f:(fun { Location.txt; _ } -> + let result = String.equal name txt in + if not result then + log ~title "Found clashing idents %S <> %S. Ignoring UID %a." + name txt Logger.fmt + (Fun.flip Shape.Uid.print uid); + result) + ~default:false in let related_uids = match scope with @@ -328,7 +329,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = List.fold_left ~init:(Occurrence_set.empty, String.Set.empty) ~f:(fun (acc_locs, acc_files) (locs, files) -> - (Occurrence_set.union acc_locs locs, String.Set.union acc_files files)) + (Occurrence_set.union acc_locs locs, String.Set.union acc_files files)) external_occurrences in let occurrences = @@ -360,12 +361,12 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path = let file = Filename.concat path loc.loc_start.pos_fname in Some (set_fname ~file loc) | None -> begin - match Locate.find_source ~config loc fname with - | `Found (file, _) -> Some (set_fname ~file loc) - | `File_not_found msg -> - log ~title:"occurrences" "%s" msg; - None - end + match Locate.find_source ~config loc fname with + | `Found (file, _) -> Some (set_fname ~file loc) + | `File_not_found msg -> + log ~title:"occurrences" "%s" msg; + None + end in Option.map loc ~f:(fun loc : Query_protocol.occurrence -> { loc; is_stale = Staleness.is_stale staleness })) diff --git a/src/analysis/outline.ml b/src/analysis/outline.ml index d64fb2e6a..6140a334a 100644 --- a/src/analysis/outline.ml +++ b/src/analysis/outline.ml @@ -70,12 +70,11 @@ let rec summarize node = List.concat_map (Lazy.force node.t_children) ~f:get_val_elements in let deprecated = Type_utils.is_deprecated vb.vb_attributes in - begin - match name_of_patt vb.vb_pat with - | None -> None - | Some name -> - let typ = outline_type ~env:node.t_env vb.vb_pat.pat_type in - Some (mk ~children ~location ~deprecated `Value typ name) + begin match name_of_patt vb.vb_pat with + | None -> None + | Some name -> + let typ = outline_type ~env:node.t_env vb.vb_pat.pat_type in + Some (mk ~children ~location ~deprecated `Value typ name) end | Value_description vd -> let deprecated = Type_utils.is_deprecated vd.val_attributes in @@ -83,21 +82,19 @@ let rec summarize node = Some (mk ~location ~deprecated `Value typ vd.val_name) | Module_declaration md -> let children = get_mod_children node in - begin - match md.md_name with - | { txt = None; _ } -> None - | { txt = Some txt; loc } -> - let deprecated = Type_utils.is_deprecated md.md_attributes in - Some (mk ~children ~location ~deprecated `Module None { txt; loc }) + begin match md.md_name with + | { txt = None; _ } -> None + | { txt = Some txt; loc } -> + let deprecated = Type_utils.is_deprecated md.md_attributes in + Some (mk ~children ~location ~deprecated `Module None { txt; loc }) end | Module_binding mb -> let children = get_mod_children node in - begin - match mb.mb_name with - | { txt = None; _ } -> None - | { txt = Some txt; loc } -> - let deprecated = Type_utils.is_deprecated mb.mb_attributes in - Some (mk ~children ~location ~deprecated `Module None { txt; loc }) + begin match mb.mb_name with + | { txt = None; _ } -> None + | { txt = Some txt; loc } -> + let deprecated = Type_utils.is_deprecated mb.mb_attributes in + Some (mk ~children ~location ~deprecated `Module None { txt; loc }) end | Module_type_declaration mtd -> let children = get_mod_children node in @@ -172,15 +169,15 @@ and get_class_elements node = in cf.cf_desc |> get_class_field_desc_infos |> Option.map ~f:(fun (str_loc, outline_kind) -> - let deprecated = Type_utils.is_deprecated cf.cf_attributes in - { Query_protocol.outline_name = str_loc.Location.txt; - outline_kind; - outline_type = None; - location = cf.cf_loc; - selection = str_loc.loc; - children; - deprecated - }) + let deprecated = Type_utils.is_deprecated cf.cf_attributes in + { Query_protocol.outline_name = str_loc.Location.txt; + outline_kind; + outline_type = None; + location = cf.cf_loc; + selection = str_loc.loc; + children; + deprecated + }) |> Option.to_list | Class_field_kind _ -> List.concat_map (Lazy.force node.t_children) ~f:get_val_elements @@ -190,16 +187,16 @@ and get_class_elements node = List.filter_map csig_fields ~f:(fun field -> get_class_signature_field_desc_infos field.ctf_desc |> Option.map ~f:(fun (name, outline_kind) -> - let deprecated = Type_utils.is_deprecated field.ctf_attributes in - { Query_protocol.outline_name = name; - outline_kind; - outline_type = None; - location = field.ctf_loc; - selection = field.ctf_loc; - (* TODO: could we have more precised location information? *) - children = []; - deprecated - })) + let deprecated = Type_utils.is_deprecated field.ctf_attributes in + { Query_protocol.outline_name = name; + outline_kind; + outline_type = None; + location = field.ctf_loc; + selection = field.ctf_loc; + (* TODO: could we have more precised location information? *) + children = []; + deprecated + })) | _ -> [] and get_class_field_desc_infos = function diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 1012e0569..e9e57bcbf 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -16,18 +16,18 @@ let rec normalize_path env path = match Env.find_type path env with | exception Not_found -> path | decl -> ( - match decl.Types.type_manifest with - | Some body - when decl.Types.type_private = Asttypes.Public - || - match decl.Types.type_kind with - | Types.Type_abstract _ -> false - | _ -> true -> begin - match Types.get_desc body with - | Types.Tconstr (path, _, _) -> normalize_path env path - | _ -> path - end - | _ -> path) + match decl.Types.type_manifest with + | Some body + when decl.Types.type_private = Asttypes.Public + || + match decl.Types.type_kind with + | Types.Type_abstract _ -> false + | _ -> true -> begin + match Types.get_desc body with + | Types.Tconstr (path, _, _) -> normalize_path env path + | _ -> path + end + | _ -> path) let match_query env query t = let cost = ref 0 in @@ -37,16 +37,15 @@ let match_query env query t = match Types.get_desc t with | Types.Tconstr (path, params, _) -> remove cost pos (normalize_path env path); - begin - match Env.find_type path env with - | exception Not_found -> () - | { Types.type_variance; _ } -> - List.iter2 type_variance params ~f:(fun var arg -> - if Types.Variance.mem Types.Variance.Inj var then ( - if Types.Variance.mem Types.Variance.Pos var then - traverse neg neg_fun pos pos_fun arg; - if Types.Variance.mem Types.Variance.Neg var then - traverse pos pos_fun neg neg_fun arg)) + begin match Env.find_type path env with + | exception Not_found -> () + | { Types.type_variance; _ } -> + List.iter2 type_variance params ~f:(fun var arg -> + if Types.Variance.mem Types.Variance.Inj var then ( + if Types.Variance.mem Types.Variance.Pos var then + traverse neg neg_fun pos pos_fun arg; + if Types.Variance.mem Types.Variance.Neg var then + traverse pos pos_fun neg neg_fun arg)) end | Types.Tarrow (_, t1, t2, _) -> decr pos_fun; @@ -114,10 +113,11 @@ let directories ~global_modules env = in List.fold_left ~f:(fun l name -> - let lident = Longident.Lident name in - match Env.find_module_by_name lident env with - | exception _ -> l - | _ -> Trie (name, lident, lazy (explore (Location.mknoloc lident) env)) :: l) + let lident = Longident.Lident name in + match Env.find_module_by_name lident env with + | exception _ -> l + | _ -> + Trie (name, lident, lazy (explore (Location.mknoloc lident) env)) :: l) ~init:[] global_modules (*Env.fold_modules (fun name _ _ l -> ignore (seen name); @@ -129,9 +129,9 @@ let execute_query query env dirs = let direct dir acc = Env.fold_values (fun _ path desc acc -> - match match_query env query desc.Types.val_type with - | Some cost -> (cost, path, desc) :: acc - | None -> acc) + match match_query env query desc.Types.val_type with + | Some cost -> (cost, path, desc) :: acc + | None -> acc) dir env acc in let rec recurse acc (Trie (_, dir, children)) = diff --git a/src/analysis/ptyp_of_type.ml b/src/analysis/ptyp_of_type.ml index 290e9d2ca..d4fcd1cb5 100644 --- a/src/analysis/ptyp_of_type.ml +++ b/src/analysis/ptyp_of_type.ml @@ -36,7 +36,8 @@ and core_type type_expr = | 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:(fun (label, ty) -> label, core_type ty) type_exprs + Typ.tuple + @@ List.map ~f:(fun (label, ty) -> (label, core_type ty)) 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 @@ -55,7 +56,7 @@ and core_type type_expr = | _ -> failwith @@ Format.asprintf "Unexpected type constructor in fields list: %a" - Printtyp.type_expr type_expr + Printtyp.type_expr type_expr in let fields, closed = aux [] type_expr in Typ.object_ fields closed @@ -84,17 +85,17 @@ and core_type type_expr = 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") + 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 { pack_path; pack_cstrs = lids_type_exprs } -> let lid = mknoloc (Untypeast.lident_of_path pack_path) in let package_type = - Typ.package_type lid @@ - List.map lids_type_exprs ~f:(fun (id, t) -> + Typ.package_type lid + @@ List.map lids_type_exprs ~f:(fun (id, t) -> let lid = Longident.unflatten id |> Option.get in (mknoloc lid, core_type t)) in @@ -116,7 +117,7 @@ and extension_constructor id { ext_args; ext_ret_type; ext_attributes; _ } = (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_; @@ -220,8 +221,8 @@ and signature_item (str_item : Types.signature_item) = 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) + | 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 = diff --git a/src/analysis/signature_help.ml b/src/analysis/signature_help.ml index 9721264ad..7ca861144 100644 --- a/src/analysis/signature_help.ml +++ b/src/analysis/signature_help.ml @@ -23,8 +23,10 @@ let extract_ident (exp_desc : Typedtree.expression_desc) = let rec longident ppf : Longident.t -> unit = function | Lident s -> Format.fprintf ppf "%s" (Misc_utils.parenthesize_name s) | Ldot (p, s) -> - Format.fprintf ppf "%a.%s" longident p.txt (Misc_utils.parenthesize_name s.txt) - | Lapply (p1, p2) -> Format.fprintf ppf "%a(%a)" longident p1.txt longident p2.txt + Format.fprintf ppf "%a.%s" longident p.txt + (Misc_utils.parenthesize_name s.txt) + | Lapply (p1, p2) -> + Format.fprintf ppf "%a(%a)" longident p1.txt longident p2.txt in match exp_desc with | Texp_ident (_, { txt = li; _ }, _) -> @@ -123,19 +125,20 @@ let first_unassigned_argument params = | _ -> false in let labelled = function - | { argument = Omitted (); label = Asttypes.Labelled _ | Optional _; _ } -> true + | { argument = Omitted (); label = Asttypes.Labelled _ | Optional _; _ } -> + true | _ -> false in try Some (List.index params ~f:positional) with Not_found -> ( - try Some (List.index params ~f:labelled) with Not_found -> None) + try Some (List.index params ~f:labelled) with Not_found -> None) let active_parameter_by_prefix ~prefix params = let common = function | Asttypes.Nolabel -> Some 0 | l when String.is_prefixed ~by:"~" prefix - || String.is_prefixed ~by:"?" prefix -> + || String.is_prefixed ~by:"?" prefix -> Some (String.common_prefix_len (Btype.prefixed_label_name l) prefix) | _ -> None in @@ -143,12 +146,12 @@ let active_parameter_by_prefix ~prefix params = let rec find_by_prefix ?(i = 0) ?longest_len ?longest_i = function | [] -> longest_i | p :: ps -> ( - match (common p.label, longest_len) with - | Some common_len, Some longest_len when common_len > longest_len -> - find_by_prefix ps ~i:(succ i) ~longest_len:common_len ~longest_i:i - | Some common_len, None -> - find_by_prefix ps ~i:(succ i) ~longest_len:common_len ~longest_i:i - | _ -> find_by_prefix ps ~i:(succ i) ?longest_len ?longest_i) + match (common p.label, longest_len) with + | Some common_len, Some longest_len when common_len > longest_len -> + find_by_prefix ps ~i:(succ i) ~longest_len:common_len ~longest_i:i + | Some common_len, None -> + find_by_prefix ps ~i:(succ i) ~longest_len:common_len ~longest_i:i + | _ -> find_by_prefix ps ~i:(succ i) ?longest_len ?longest_i) in find_by_prefix params diff --git a/src/analysis/type_enclosing.ml b/src/analysis/type_enclosing.ml index cff22d6c0..8f861eab9 100644 --- a/src/analysis/type_enclosing.ml +++ b/src/analysis/type_enclosing.ml @@ -59,11 +59,11 @@ let from_nodes ~path = ret (Modtype (env, m)) | Class_field { cf_desc = Tcf_method (_, _, Tcfk_concrete (_, { exp_type })) } -> - begin - match Types.get_desc exp_type with - | Tarrow (_, _, t, _) -> ret (Type (env, t)) - | _ -> None - end + begin + match Types.get_desc exp_type with + | Tarrow (_, _, t, _) -> ret (Type (env, t)) + | _ -> None + end | Class_field { cf_desc = Tcf_val (_, _, _, Tcfk_concrete (_, { exp_type = t }), _) } -> ret (Type (env, t)) @@ -119,28 +119,28 @@ let from_reconstructed ~nodes ~cursor ~verbosity exprs = Some (loc, Type (env, lbl_arg), `No) | Some Context.Constant -> None | _ -> ( - let context = Option.value ~default:Context.Expr context in - (* Else use the reconstructed identifier *) - match source with - | "" -> - log ~title:"from_reconstructed" "no reconstructed identifier"; - None - | source when (not include_lident) && Char.is_lowercase source.[0] -> - log ~title:"from_reconstructed" "skipping lident"; - None - | source when (not include_uident) && Char.is_uppercase source.[0] -> - log ~title:"from_reconstructed" "skipping uident"; - None - | source -> ( - try - let ppf, to_string = Format.to_string () in - if Type_utils.type_in_env ~verbosity ~context env ppf source then ( - let result = to_string () in - log ~title:"from_reconstructed" "typed %s : %s" source result; - Some (loc, String result, `No)) - else ( - log ~title:"from_reconstructed" "FAILED to type %s" source; - None) - with _ -> None)) + let context = Option.value ~default:Context.Expr context in + (* Else use the reconstructed identifier *) + match source with + | "" -> + log ~title:"from_reconstructed" "no reconstructed identifier"; + None + | source when (not include_lident) && Char.is_lowercase source.[0] -> + log ~title:"from_reconstructed" "skipping lident"; + None + | source when (not include_uident) && Char.is_uppercase source.[0] -> + log ~title:"from_reconstructed" "skipping uident"; + None + | source -> ( + try + let ppf, to_string = Format.to_string () in + if Type_utils.type_in_env ~verbosity ~context env ppf source then ( + let result = to_string () in + log ~title:"from_reconstructed" "typed %s : %s" source result; + Some (loc, String result, `No)) + else ( + log ~title:"from_reconstructed" "FAILED to type %s" source; + None) + with _ -> None)) in List.filter_map exprs ~f diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index e389bb8a4..e78ad9569 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -119,13 +119,13 @@ let values_from_module query env lident acc = let acc = compute_values query env (Some lident) acc in Env.fold_modules (fun name _ mdl acc -> - match mdl.Types.md_type with - | Types.Mty_alias _ -> acc - | _ -> - let lident = - Longident.Ldot (Location.mknoloc lident, Location.mknoloc name) - in - aux acc lident) + match mdl.Types.md_type with + | Types.Mty_alias _ -> acc + | _ -> + let lident = + Longident.Ldot (Location.mknoloc lident, Location.mknoloc name) + in + aux acc lident) (Some lident) env acc in aux acc lident diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index 507be626b..992b08c9f 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -174,32 +174,28 @@ let rec mod_smallerthan n m = match List.length_lessthan n s with | None -> None | Some _ -> - List.fold_left s ~init:(Some 0) - ~f: - begin - fun acc item -> - let sub n1 m = - match mod_smallerthan (n - n1) m with - | Some n2 -> Some (n1 + n2) - | None -> None - in - match (acc, si_modtype_opt item) with - | None, _ -> None - | Some n', _ when n' > n -> None - | Some n1, Some mty -> sub n1 mty - | Some n', _ -> Some (succ n') - end + List.fold_left s ~init:(Some 0) ~f:begin fun acc item -> + let sub n1 m = + match mod_smallerthan (n - n1) m with + | Some n2 -> Some (n1 + n2) + | None -> None + in + match (acc, si_modtype_opt item) with + | None, _ -> None + | Some n', _ when n' > n -> None + | Some n1, Some mty -> sub n1 mty + | Some n', _ -> Some (succ n') + end end | Mty_functor _ -> let m1, m2 = unpack_functor m in - begin - match (mod_smallerthan n m2, m1) with - | None, _ -> None - | result, Unit -> result - | Some n1, Named (_, mt) -> ( - match mod_smallerthan (n - n1) mt with - | None -> None - | Some n2 -> Some (n1 + n2)) + begin match (mod_smallerthan n m2, m1) with + | None, _ -> None + | result, Unit -> result + | Some n1, Named (_, mt) -> ( + match mod_smallerthan (n - n1) mt with + | None -> None + | Some n2 -> Some (n1 + n2)) end | _ -> Some 1 @@ -310,20 +306,19 @@ let type_in_env ?(verbosity = Verbosity.default) ?keywords ~context env ppf expr match extract_specific_parsing_info e with | `Ident longident | `Constr longident -> begin try - begin - match context with - | Label lbl_des -> - (* We use information from the context because `Env.find_label_by_name` + begin match context with + | Label lbl_des -> + (* We use information from the context because `Env.find_label_by_name` can fail *) - Printtyp.type_expr ppf lbl_des.lbl_arg - | Type -> - log ~title:"type_in_env" "Type type"; - print_type ppf env longident - (* TODO: special processing for module aliases ? *) - | Module_type -> print_modtype ppf verbosity env longident - | Module_path -> print_modpath ppf verbosity env longident - | Constructor _ -> print_constr ppf env longident - | _ -> raise Fallback + Printtyp.type_expr ppf lbl_des.lbl_arg + | Type -> + log ~title:"type_in_env" "Type type"; + print_type ppf env longident + (* TODO: special processing for module aliases ? *) + | Module_type -> print_modtype ppf verbosity env longident + | Module_path -> print_modpath ppf verbosity env longident + | Constructor _ -> print_constr ppf env longident + | _ -> raise Fallback end; true with _ -> ( diff --git a/src/analysis/typed_hole.ml b/src/analysis/typed_hole.ml index d71bd893c..52d73e9b0 100644 --- a/src/analysis/typed_hole.ml +++ b/src/analysis/typed_hole.ml @@ -14,4 +14,3 @@ let is_a_hole = function | (_, Browse_raw.Module_expr { mod_desc = Tmod_typed_hole; _ }) :: (_, _) :: _ | (_, Browse_raw.Expression { exp_desc = Texp_typed_hole; _ }) :: _ -> true | [] | (_, _) :: _ -> false -;; diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 744c6b288..ab7c5cbfc 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -117,19 +117,15 @@ let all_commands = this variable.\n\ The return value has the shape `[{'start': position, 'end': \ position}, content]`, where content is string.\n" - ~default:(`Offset (-1), `Offset (-1)) - begin - fun buffer -> function - | `Offset -1, _ -> failwith "-start is mandatory" - | _, `Offset -1 -> failwith "-end is mandatory" - | startp, endp -> - run buffer (Query_protocol.Case_analysis (startp, endp)) + ~default:(`Offset (-1), `Offset (-1)) begin fun buffer -> function + | `Offset -1, _ -> failwith "-start is mandatory" + | _, `Offset -1 -> failwith "-end is mandatory" + | startp, endp -> run buffer (Query_protocol.Case_analysis (startp, endp)) end; command "holes" ~spec:[] ~doc:"Returns the list of the positions of all the holes in the file." - ~default:() - begin - fun buffer () -> run buffer Query_protocol.Holes + ~default:() begin fun buffer () -> + run buffer Query_protocol.Holes end; command "construct" ~spec: @@ -159,12 +155,11 @@ let all_commands = results of\n\ inferior depth will not be returned." ~default:(`Offset (-1), None, None) - begin - fun buffer (pos, with_values, max_depth) -> - match pos with - | `Offset -1 -> failwith "-position is mandatory" - | pos -> - run buffer (Query_protocol.Construct (pos, with_values, max_depth)) + begin fun buffer (pos, with_values, max_depth) -> + match pos with + | `Offset -1 -> failwith "-position is mandatory" + | pos -> + run buffer (Query_protocol.Construct (pos, with_values, max_depth)) end; command "complete-prefix" ~spec: @@ -216,14 +211,12 @@ let all_commands = - optional information which might not fit in the completion box, \ like signatures for modules or documentation string." ~default:("", `None, [], false, true) - begin - fun buffer (txt, pos, kinds, doc, typ) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer - (Query_protocol.Complete_prefix - (txt, pos, List.rev kinds, doc, typ)) + begin fun buffer (txt, pos, kinds, doc, typ) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer + (Query_protocol.Complete_prefix (txt, pos, List.rev kinds, doc, typ)) end; command "document" ~doc: @@ -237,14 +230,11 @@ let all_commands = (marg_position (fun pos (ident, _pos) -> (ident, pos))); optional "-identifier" " Identifier" (Marg.param "string" (fun ident (_ident, pos) -> (Some ident, pos))) - ] - ~default:(None, `None) - begin - fun buffer (ident, pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Document (ident, pos)) + ] ~default:(None, `None) begin fun buffer (ident, pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Document (ident, pos)) end; command "syntax-document" ~doc: @@ -252,27 +242,20 @@ let all_commands = ~spec: [ arg "-position" " Position to complete" (marg_position (fun pos _pos -> pos)) - ] - ~default:`None - begin - fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Syntax_document pos) + ] ~default:`None begin fun buffer pos -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Syntax_document pos) end; command "expand-ppx" ~doc:"Returns the generated code of a PPX." ~spec: [ arg "-position" " Position to expand" (marg_position (fun pos _pos -> pos)) - ] - ~default:`None - begin - fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Expand_ppx pos) + ] ~default:`None begin fun buffer pos -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> run buffer (Query_protocol.Expand_ppx pos) end; command "enclosing" ~spec: @@ -283,14 +266,10 @@ let all_commands = "Returns a list of locations `{'start': position, 'end': position}` in \ increasing size of all entities surrounding the position.\n\ (In a lisp, this would be the locations of all s-exps that contain \ - the cursor.)" - ~default:`None - begin - fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Enclosing pos) + the cursor.)" ~default:`None begin fun buffer pos -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> run buffer (Query_protocol.Enclosing pos) end; command "errors" ~spec: @@ -321,10 +300,8 @@ let all_commands = Merlin was expecting such an error to be possible or not, and is \ useful for debugging purposes.\n\ `message` is the error description to be shown to the user." - ~default:(true, true, true) - begin - fun buffer (lexing, parsing, typing) -> - run buffer (Query_protocol.Errors { lexing; parsing; typing }) + ~default:(true, true, true) begin fun buffer (lexing, parsing, typing) -> + run buffer (Query_protocol.Errors { lexing; parsing; typing }) end; command "expand-prefix" ~doc: @@ -353,15 +330,13 @@ let all_commands = cursor context" (marg_completion_kind (fun kind (txt, pos, kinds, typ) -> (txt, pos, kind :: kinds, typ))) - ] - ~default:("", `None, [], false) - begin - fun buffer (txt, pos, kinds, typ) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer - (Query_protocol.Expand_prefix (txt, pos, List.rev kinds, typ)) + ] ~default:("", `None, [], false) + begin fun buffer (txt, pos, kinds, typ) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer + (Query_protocol.Expand_prefix (txt, pos, List.rev kinds, typ)) end; command "extension-list" ~spec: @@ -376,25 +351,20 @@ let all_commands = ] ~doc: "List all known / currently enabled / currently disabled extensions as \ - a list of strings." - ~default:`All - begin - fun buffer status -> run buffer (Query_protocol.Extension_list status) + a list of strings." ~default:`All begin fun buffer status -> + run buffer (Query_protocol.Extension_list status) end; command "findlib-list" ~doc:"Returns all known findlib packages as a list of string." ~spec:[] - ~default:() - begin - fun buffer () -> run buffer Query_protocol.Findlib_list + ~default:() begin fun buffer () -> + run buffer Query_protocol.Findlib_list end; command "flags-list" ~spec:[] ~doc: "Returns supported compiler flags.The purpose of this command is to \ implement interactive completion of compiler settings in an IDE." - ~default:() - begin - fun _ () -> - `List (List.map ~f:Json.string (Mconfig.flags_for_completion ())) + ~default:() begin fun _ () -> + `List (List.map ~f:Json.string (Mconfig.flags_for_completion ())) end; command "jump" ~spec: @@ -409,13 +379,11 @@ let all_commands = 'module', 'module-type' and 'match' words.\n\ It returns the starting position of the function, let definition, \ module or match expression that contains the cursor\n" - ~default:("", `None) - begin - fun buffer (target, pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Jump (target, pos)) + ~default:("", `None) begin fun buffer (target, pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Jump (target, pos)) end; command "phrase" ~spec: @@ -430,14 +398,12 @@ let all_commands = ] ~doc: "Returns the position of the next or previous phrase (top-level \ - definition or module definition)." - ~default:(`Next, `None) - begin - fun buffer (target, pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Phrase (target, pos)) + definition or module definition)." ~default:(`Next, `None) + begin fun buffer (target, pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Phrase (target, pos)) end; command "list-modules" ~spec: @@ -446,11 +412,9 @@ let all_commands = ] ~doc: "Looks into project source paths for files with an extension matching \ - and prints the corresponding module name." - ~default:[] - begin - fun buffer extensions -> - run buffer (Query_protocol.List_modules (List.rev extensions)) + and prints the corresponding module name." ~default:[] + begin fun buffer extensions -> + run buffer (Query_protocol.List_modules (List.rev extensions)) end; command "locate" ~spec: @@ -478,14 +442,12 @@ let all_commands = - if location failed, a `string` describing the reason to the user,\n\ - `{'pos': position}` if the location is in the current buffer,\n\ - `{'file': string, 'pos': position}` if definition is located in a \ - different file." - ~default:(None, `None, `MLI) - begin - fun buffer (prefix, pos, lookfor) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Locate (prefix, lookfor, pos)) + different file." ~default:(None, `None, `MLI) + begin fun buffer (prefix, pos, lookfor) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Locate (prefix, lookfor, pos)) end; command "locate-type" ~spec: @@ -493,12 +455,10 @@ let all_commands = (marg_position (fun pos _ -> pos)) ] ~doc:"Locate the declaration of the type of the expression" ~default:`None - begin - fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Locate_type pos) + begin fun buffer pos -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> run buffer (Query_protocol.Locate_type pos) end; command "locate-types" ~spec: @@ -508,14 +468,10 @@ let all_commands = ~doc: "Locate the declaration of the type of the expression. If the type is \ expressed via multiple identifiers, it returns the location of each \ - identifier." - ~default:`None - begin - fun buffer pos -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Locate_types pos) + identifier." ~default:`None begin fun buffer pos -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> run buffer (Query_protocol.Locate_types pos) end; command "occurrences" ~spec: @@ -532,22 +488,17 @@ let all_commands = ~doc: "Returns a list of locations `{'start': position, 'end': position}` of \ all occurrences in current buffer of the entity at the specified \ - position." - ~default:(`None, `Buffer) - begin - fun buffer -> function - | `None, _ -> failwith "-identifier-at is mandatory" - | `Ident_at pos, scope -> - run buffer (Query_protocol.Occurrences (`Ident_at pos, scope)) + position." ~default:(`None, `Buffer) begin fun buffer -> function + | `None, _ -> failwith "-identifier-at is mandatory" + | `Ident_at pos, scope -> + run buffer (Query_protocol.Occurrences (`Ident_at pos, scope)) end; command "outline" ~spec:[] ~doc: "Returns a tree of objects `{'start': position, 'end': position, \ 'name': string, 'kind': string, 'children': subnodes}` describing the \ - content of the buffer." - ~default:() - begin - fun buffer () -> run buffer Query_protocol.Outline + content of the buffer." ~default:() begin fun buffer () -> + run buffer Query_protocol.Outline end; command "path-of-source" ~doc: @@ -556,11 +507,8 @@ let all_commands = ~spec: [ arg "-file" " filename to look for in project paths" (Marg.param "filename" (fun file files -> file :: files)) - ] - ~default:[] - begin - fun buffer filenames -> - run buffer (Query_protocol.Path_of_source (List.rev filenames)) + ] ~default:[] begin fun buffer filenames -> + run buffer (Query_protocol.Path_of_source (List.rev filenames)) end; command "refactor-open" ~doc:"refactor-open -position pos -action \n\tTODO" @@ -573,14 +521,11 @@ let all_commands = | "qualify" -> (Some `Qualify, pos) | "unqualify" -> (Some `Unqualify, pos) | _ -> failwith "invalid -action")) - ] - ~default:(None, `None) - begin - fun buffer -> function - | None, _ -> failwith "-action is mandatory" - | _, `None -> failwith "-position is mandatory" - | Some action, (#Msource.position as pos) -> - run buffer (Query_protocol.Refactor_open (action, pos)) + ] ~default:(None, `None) begin fun buffer -> function + | None, _ -> failwith "-action is mandatory" + | _, `None -> failwith "-position is mandatory" + | Some action, (#Msource.position as pos) -> + run buffer (Query_protocol.Refactor_open (action, pos)) end; command "search-by-polarity" ~doc:"search-by-polarity -position pos -query ident\n\tTODO" @@ -593,14 +538,11 @@ let all_commands = +option will fetch function that takes string and returns an \ option. (You can't parametrize types in polarity queries)" (Marg.param "string" (fun query (_prefix, pos) -> (query, pos))) - ] - ~default:("", `None) - begin - fun buffer (query, pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Polarity_search (query, pos)) + ] ~default:("", `None) begin fun buffer (query, pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Polarity_search (query, pos)) end; command "search-by-type" ~doc:"return a list of values that match a query" ~spec: @@ -617,18 +559,15 @@ let all_commands = optional "-with-doc" " include docstring (default is false)" (Marg.bool (fun with_doc (query, pos, limit, _with_doc) -> (query, pos, limit, with_doc))) - ] - ~default:(None, `None, 100, false) - begin - fun buffer (query, pos, limit, with_doc) -> - match (query, pos) with - | None, `None -> - failwith "-position and -query are mandatory" - | None, _ -> failwith "-query is mandatory" - | _, `None -> failwith "-position is mandatory" - | Some query, (#Msource.position as pos) -> - run buffer - (Query_protocol.Type_search (query, pos, limit, with_doc)) + ] ~default:(None, `None, 100, false) + begin fun buffer (query, pos, limit, with_doc) -> + match (query, pos) with + | None, `None -> + failwith "-position and -query are mandatory" + | None, _ -> failwith "-query is mandatory" + | _, `None -> failwith "-position is mandatory" + | Some query, (#Msource.position as pos) -> + run buffer (Query_protocol.Type_search (query, pos, limit, with_doc)) end; command "inlay-hints" ~doc:"return a list of inly-hints for additional client (like LSP)" @@ -738,31 +677,25 @@ let all_commands = pattern_binding, function_params, ghost ))) - ] - ~default:(`None, `None, false, false, false, true) - begin - fun buffer - ( start, - stop, - let_binding, - pattern_binding, - function_params, - avoid_ghost ) - -> - match (start, stop) with - | `None, `None -> failwith "-start and -end are mandatory" - | `None, _ -> failwith "-start is mandatory" - | _, `None -> failwith "-end is mandatory" - | (#Msource.position, #Msource.position) as position -> - let start, stop = position in - run buffer - (Query_protocol.Inlay_hints - ( start, - stop, - let_binding, - pattern_binding, - function_params, - avoid_ghost )) + ] ~default:(`None, `None, false, false, false, true) + begin fun + buffer + (start, stop, let_binding, pattern_binding, function_params, avoid_ghost) + -> + match (start, stop) with + | `None, `None -> failwith "-start and -end are mandatory" + | `None, _ -> failwith "-start is mandatory" + | _, `None -> failwith "-end is mandatory" + | (#Msource.position, #Msource.position) as position -> + let start, stop = position in + run buffer + (Query_protocol.Inlay_hints + ( start, + stop, + let_binding, + pattern_binding, + function_params, + avoid_ghost )) end; command "shape" ~doc: @@ -781,12 +714,9 @@ let all_commands = ~spec: [ arg "-position" " Position " (marg_position (fun pos _pos -> pos)) - ] - ~default:`None - begin - fun buffer -> function - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> run buffer (Query_protocol.Shape pos) + ] ~default:`None begin fun buffer -> function + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> run buffer (Query_protocol.Shape pos) end; command "type-enclosing" ~doc: @@ -830,22 +760,18 @@ let all_commands = match int_of_string index with | index -> (expr, cursor, pos, Some index) | exception _ -> failwith "index should be an integer")) - ] - ~default:("", -1, `None, None) - begin - fun buffer (expr, cursor, pos, index) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - let expr = - if expr = "" then None - else - let cursor = - if cursor = -1 then String.length expr else cursor - in - Some (expr, cursor) - in - run buffer (Query_protocol.Type_enclosing (expr, pos, index)) + ] ~default:("", -1, `None, None) + begin fun buffer (expr, cursor, pos, index) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + let expr = + if expr = "" then None + else + let cursor = if cursor = -1 then String.length expr else cursor in + Some (expr, cursor) + in + run buffer (Query_protocol.Type_enclosing (expr, pos, index)) end; command "type-expression" ~doc: @@ -856,14 +782,11 @@ let all_commands = (marg_position (fun pos (expr, _pos) -> (expr, pos))); arg "-expression" " Expression to type" (Marg.param "string" (fun expr (_expr, pos) -> (expr, pos))) - ] - ~default:("", `None) - begin - fun buffer (expr, pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as pos -> - run buffer (Query_protocol.Type_expr (expr, pos)) + ] ~default:("", `None) begin fun buffer (expr, pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Type_expr (expr, pos)) end; (* Implemented without support from Query_protocol. This command might be refactored if it proves useful for old protocol too. *) @@ -876,48 +799,42 @@ let all_commands = \ 'dot_merlins': [path], // a list of string\n\ \ 'failures': [message] // a list of string\n\ }\n\ - ```" - ~default:() - begin - fun pipeline () -> - let config = Mpipeline.final_config pipeline in - `Assoc - [ (* TODO Remove support for multiple configuration files + ```" ~default:() begin fun pipeline () -> + let config = Mpipeline.final_config pipeline in + `Assoc + [ (* TODO Remove support for multiple configuration files The protocol could be changed to: 'config_file': path_to_dot_merlin_or_dune For now, if the configurator is dune, the field 'dot_merlins' will contain the path to the dune file (or jbuild, or dune-project) *) - ( "dot_merlins", - `List - (match Mconfig.(config.merlin.config_path) with - | Some path -> [ Json.string path ] - | None -> []) ); - ( "failures", - `List (List.map ~f:Json.string Mconfig.(config.merlin.failures)) - ) - ] + ( "dot_merlins", + `List + (match Mconfig.(config.merlin.config_path) with + | Some path -> [ Json.string path ] + | None -> []) ); + ( "failures", + `List (List.map ~f:Json.string Mconfig.(config.merlin.failures)) + ) + ] end; command "signature-help" ~doc:"Returns LSP Signature Help response" ~spec: [ arg "-position" " Position of Signature Help request" (marg_position (fun pos (expr, _pos) -> (expr, pos))) - ] - ~default:("", `None) - begin - fun buffer (_, pos) -> - match pos with - | `None -> failwith "-position is mandatory" - | #Msource.position as position -> - let sh = - { Query_protocol.position; - trigger_kind = None; - is_retrigger = false; - active_signature_help = None - } - in - run buffer (Query_protocol.Signature_help sh) + ] ~default:("", `None) begin fun buffer (_, pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as position -> + let sh = + { Query_protocol.position; + trigger_kind = None; + is_retrigger = false; + active_signature_help = None + } + in + run buffer (Query_protocol.Signature_help sh) end; (* Used only for testing *) command "dump" @@ -926,15 +843,14 @@ let all_commands = " \ Information to dump ()" (Marg.param "string" (fun what _ -> what)) - ] - ~default:"" ~doc:"Not for the casual user, used for debugging merlin" - begin - fun pipeline what -> run pipeline (Query_protocol.Dump [ `String what ]) + ] ~default:"" ~doc:"Not for the casual user, used for debugging merlin" + begin fun pipeline what -> + run pipeline (Query_protocol.Dump [ `String what ]) end; (* Used only for testing *) command "dump-configuration" ~spec:[] ~default:() ~doc:"Not for the casual user, used for merlin tests" - begin - fun pipeline () -> Mconfig.dump (Mpipeline.final_config pipeline) + begin fun pipeline () -> + Mconfig.dump (Mpipeline.final_config pipeline) end ] diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index e657b37e7..c0fa4c3fe 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -398,8 +398,7 @@ let json_of_locate_types (resp : Locate_types_result.t) = `List (`String variant_name :: payload) in let json_of_node_data : - Locate_types_result.(type_ref_payload Tree.node_data) -> - _ = function + Locate_types_result.(type_ref_payload Tree.node_data) -> _ = function | Arrow -> `List [ `String "Arrow" ] | Tuple -> `List [ `String "Tuple" ] | Object -> `List [ `String "Object" ] diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index c11782ab4..f393eedb4 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -41,10 +41,9 @@ let findlib_ok = in (* This is a quick and dirty workaround to get Merlin to work even when findlib directory has been removed. *) - begin - match Sys.getenv "OCAMLFIND_CONF" with - | exception Not_found -> Unix.putenv "OCAMLFIND_CONF" "/dev/null" - | _ -> () + begin match Sys.getenv "OCAMLFIND_CONF" with + | exception Not_found -> Unix.putenv "OCAMLFIND_CONF" "/dev/null" + | _ -> () end; Error ("Error during findlib initialization: " ^ message) @@ -206,20 +205,18 @@ let ppx_of_package ?(predicates = []) setup pkg = (Findlib.package_property predicates pkg "ppxopt")) with Not_found -> [] in - begin - match ppx with - | None -> () - | Some ppx -> log ~title:"ppx" "%s" ppx + begin match ppx with + | None -> () + | Some ppx -> log ~title:"ppx" "%s" ppx end; - begin - match ppxopts with - | [] -> () - | lst -> - log ~title:"ppx options" "%a" Logger.json @@ fun () -> - let f (ppx, opts) = - `List [ `String ppx; `List (List.map ~f:(fun s -> `String s) opts) ] - in - `List (List.map ~f lst) + begin match ppxopts with + | [] -> () + | lst -> + log ~title:"ppx options" "%a" Logger.json @@ fun () -> + let f (ppx, opts) = + `List [ `String ppx; `List (List.map ~f:(fun s -> `String s) opts) ] + in + `List (List.map ~f lst) end; let setup = match ppx with @@ -346,11 +343,10 @@ let prepend_config ~cwd ~cfg = | `PKG ps -> { cfg with packages_to_load = ps @ cfg.packages_to_load } | `STDLIB path -> let canon_path = canonicalize_filename ~cwd path in - begin - match cfg.stdlib with - | None -> () - | Some p -> - log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path + begin match cfg.stdlib with + | None -> () + | Some p -> + log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path end; { cfg with stdlib = Some canon_path } | `SOURCE_ROOT path -> @@ -358,22 +354,20 @@ let prepend_config ~cwd ~cfg = { cfg with source_root = Some canon_path } | `FINDLIB path -> let canon_path = canonicalize_filename ~cwd path in - begin - match cfg.stdlib with - | None -> () - | Some p -> - log ~title:"conflicting paths for findlib" "%s\n%s" p canon_path + begin match cfg.stdlib with + | None -> () + | Some p -> + log ~title:"conflicting paths for findlib" "%s\n%s" p canon_path end; { cfg with findlib = Some canon_path } | `FINDLIB_PATH path -> let canon_path = canonicalize_filename ~cwd path in { cfg with findlib_path = canon_path :: cfg.findlib_path } | `FINDLIB_TOOLCHAIN path -> - begin - match cfg.stdlib with - | None -> () - | Some p -> - log ~title:"conflicting paths for findlib toolchain" "%s\n%s" p path + begin match cfg.stdlib with + | None -> () + | Some p -> + log ~title:"conflicting paths for findlib toolchain" "%s\n%s" p path end; { cfg with findlib_toolchain = Some path }) diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index cf7244a3e..302085c91 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -111,12 +111,11 @@ module Sexp = struct end | List [ Atom tag; List l ] -> let value = strings_of_atoms l in - begin - match tag with - | "EXT" -> `EXT value - | "FLG" -> `FLG value - | "READER" -> `READER value - | tag -> `UNKNOWN_TAG tag + begin match tag with + | "EXT" -> `EXT value + | "FLG" -> `FLG value + | "READER" -> `READER value + | tag -> `UNKNOWN_TAG tag end | List [ Atom "EXCLUDE_QUERY_DIR" ] -> `EXCLUDE_QUERY_DIR | List [ Atom "USE_PPX_CACHE" ] -> `USE_PPX_CACHE diff --git a/src/extend/extend_driver.ml b/src/extend/extend_driver.ml index 2dfe8ffa5..34e867c2f 100644 --- a/src/extend/extend_driver.ml +++ b/src/extend/extend_driver.ml @@ -23,7 +23,8 @@ let run ?(notify = ignore) ?(debug = ignore) name = Unix.set_close_on_exec stdout; let ocamlmerlin_name = "ocamlmerlin-" ^ name in let pid = - Unix.create_process ocamlmerlin_name [| ocamlmerlin_name |] pstdin pstdout Unix.stderr + Unix.create_process ocamlmerlin_name [| ocamlmerlin_name |] pstdin pstdout + Unix.stderr in Unix.close pstdout; Unix.close pstdin; diff --git a/src/extend/extend_main.ml b/src/extend/extend_main.ml index b09505bb1..50dcfedbf 100644 --- a/src/extend/extend_main.ml +++ b/src/extend/extend_main.ml @@ -137,16 +137,15 @@ end (** The main entry point of an extension. *) let extension_main ?reader desc = (* Check if invoked from Merlin *) - begin - match Sys.getenv "__MERLIN_MASTER_PID" with - | exception Not_found -> - Printf.eprintf - "This is %s merlin extension, version %s.\n\ - This binary should be invoked from merlin and cannot be used directly.\n\ - %!" - desc.P.name desc.P.version; - exit 1 - | _ -> () + begin match Sys.getenv "__MERLIN_MASTER_PID" with + | exception Not_found -> + Printf.eprintf + "This is %s merlin extension, version %s.\n\ + This binary should be invoked from merlin and cannot be used directly.\n\ + %!" + desc.P.name desc.P.version; + exit 1 + | _ -> () end; (* Communication happens on stdin/stdout. *) Handshake.negotiate { P.reader = reader <> None }; diff --git a/src/frontend/ocamlmerlin/new/new_merlin.ml b/src/frontend/ocamlmerlin/new/new_merlin.ml index 78e13d9c3..12110321f 100644 --- a/src/frontend/ocamlmerlin/new/new_merlin.ml +++ b/src/frontend/ocamlmerlin/new/new_merlin.ml @@ -163,10 +163,9 @@ let run = ] in log ~title:"run(result)" "%a" Logger.json (fun () -> json); - begin - match Mconfig.(config.merlin.protocol) with - | `Sexp -> Sexp.tell_sexp print_string (Sexp.of_json json) - | `Json -> Yojson.Basic.to_channel stdout json + begin match Mconfig.(config.merlin.protocol) with + | `Sexp -> Sexp.tell_sexp print_string (Sexp.of_json json) + | `Json -> Yojson.Basic.to_channel stdout json end; print_newline () end @@ -187,12 +186,11 @@ let with_wd ~wd ~old_wd f args = f args let run ~new_env wd args = - begin - match new_env with - | Some env -> - Os_ipc.merlin_set_environ env; - Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ())) - | None -> () + begin match new_env with + | Some env -> + Os_ipc.merlin_set_environ env; + Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ())) + | None -> () end; let old_wd = Sys.getcwd () in let run args () = diff --git a/src/frontend/ocamlmerlin/old/old_IO.ml b/src/frontend/ocamlmerlin/old/old_IO.ml index 1ef04be4e..2e96b3f76 100644 --- a/src/frontend/ocamlmerlin/old/old_IO.ml +++ b/src/frontend/ocamlmerlin/old/old_IO.ml @@ -341,21 +341,19 @@ let make_json ?(on_read = ignore) ~input ~output () = let make_sexp ?on_read ~input ~output () = (* Fix for emacs: emacs start-process doesn't distinguish between stdout and stderr. So we redirect stderr to /dev/null with sexp frontend. *) - begin - match - begin - try Some (Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o600) - with Unix.Unix_error _ -> - if Sys.os_type = "Win32" then - try Some (Unix.openfile "NUL" [ Unix.O_WRONLY ] 0o600) - with Unix.Unix_error _ -> None - else None - end - with - | None -> () - | Some fd -> - Unix.dup2 fd Unix.stderr; - Unix.close fd + begin match + begin try Some (Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o600) + with Unix.Unix_error _ -> + if Sys.os_type = "Win32" then + try Some (Unix.openfile "NUL" [ Unix.O_WRONLY ] 0o600) + with Unix.Unix_error _ -> None + else None + end + with + | None -> () + | Some fd -> + Unix.dup2 fd Unix.stderr; + Unix.close fd end; let input' = Sexp.of_file_descr ?on_read input in let input' () = Option.map ~f:Sexp.to_json (input' ()) in diff --git a/src/frontend/ocamlmerlin/old/old_command.ml b/src/frontend/ocamlmerlin/old/old_command.ml index 829729315..5f4bb9894 100644 --- a/src/frontend/ocamlmerlin/old/old_command.ml +++ b/src/frontend/ocamlmerlin/old/old_command.ml @@ -117,12 +117,11 @@ let checkout_buffer = try List.assoc document !checkout_buffer_cache with Not_found -> let buffer = new_buffer document in - begin - match document with - | Some _, _ -> - checkout_buffer_cache := - (document, buffer) :: List.take_n cache_size !checkout_buffer_cache - | None, _ -> () + begin match document with + | Some _, _ -> + checkout_buffer_cache := + (document, buffer) :: List.take_n cache_size !checkout_buffer_cache + | None, _ -> () end; buffer @@ -182,12 +181,11 @@ let dispatch_sync config state (type a) : a sync_command -> a = function | _ -> true) state.customization | Protocol_version version -> - begin - match version with - | None -> () - | Some 2 -> Old_IO.current_version := `V2 - | Some 3 -> Old_IO.current_version := `V3 - | Some _ -> () + begin match version with + | None -> () + | Some 2 -> Old_IO.current_version := `V2 + | Some 3 -> Old_IO.current_version := `V3 + | Some _ -> () end; ( `Selected !Old_IO.current_version, `Latest Old_IO.latest_version, diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 75fc431be..456b17a88 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -73,40 +73,36 @@ let verbosity pipeline = let dump pipeline = function | [ `String "ppxed-source" ] -> let ppf, to_string = Format.to_string () in - begin - match Mpipeline.ppx_parsetree pipeline with - | `Interface s -> Pprintast.signature ppf s - | `Implementation s -> Pprintast.structure ppf s + begin match Mpipeline.ppx_parsetree pipeline with + | `Interface s -> Pprintast.signature ppf s + | `Implementation s -> Pprintast.structure ppf s end; Format.pp_print_newline ppf (); Format.pp_force_newline ppf (); `String (to_string ()) | [ `String "source" ] -> let ppf, to_string = Format.to_string () in - begin - match Mpipeline.reader_parsetree pipeline with - | `Interface s -> Pprintast.signature ppf s - | `Implementation s -> Pprintast.structure ppf s + begin match Mpipeline.reader_parsetree pipeline with + | `Interface s -> Pprintast.signature ppf s + | `Implementation s -> Pprintast.structure ppf s end; Format.pp_print_newline ppf (); Format.pp_force_newline ppf (); `String (to_string ()) | [ `String "parsetree" ] -> let ppf, to_string = Format.to_string () in - begin - match Mpipeline.reader_parsetree pipeline with - | `Interface s -> Printast.interface ppf s - | `Implementation s -> Printast.implementation ppf s + begin match Mpipeline.reader_parsetree pipeline with + | `Interface s -> Printast.interface ppf s + | `Implementation s -> Printast.implementation ppf s end; Format.pp_print_newline ppf (); Format.pp_force_newline ppf (); `String (to_string ()) | [ `String "ppxed-parsetree" ] -> let ppf, to_string = Format.to_string () in - begin - match Mpipeline.ppx_parsetree pipeline with - | `Interface s -> Printast.interface ppf s - | `Implementation s -> Printast.implementation ppf s + begin match Mpipeline.ppx_parsetree pipeline with + | `Interface s -> Printast.interface ppf s + | `Implementation s -> Printast.implementation ppf s end; Format.pp_print_newline ppf (); Format.pp_force_newline ppf (); @@ -185,10 +181,9 @@ let dump pipeline = function | [ `String "typedtree" ] -> let tree = Mpipeline.typer_result pipeline |> Mtyper.get_typedtree in let ppf, to_string = Format.to_string () in - begin - match tree with - | `Interface s -> Printtyped.interface ppf s - | `Implementation s -> Printtyped.implementation ppf s + begin match tree with + | `Interface s -> Printtyped.interface ppf s + | `Implementation s -> Printtyped.implementation ppf s end; Format.pp_print_newline ppf (); Format.pp_force_newline ppf (); @@ -330,26 +325,23 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function end | _ -> None) in - begin - match path with - | None -> `Invalid_context - | Some (env, path) -> ( - Locate.log ~title:"debug" "found type: %s" (Path.name path); - let config = - Locate. - { mconfig = Mpipeline.final_config pipeline; - ml_or_mli = `MLI; - traverse_aliases = true - } - in - match - Locate.from_path ~config ~env ~local_defs ~namespace:Type path - with - | `Builtin (_, s) -> `Builtin s - | `Not_in_env _ as s -> s - | `Not_found _ as s -> s - | `Found { file; location; _ } -> `Found (Some file, location.loc_start) - | `File_not_found { file = reason; _ } -> `File_not_found reason) + begin match path with + | None -> `Invalid_context + | Some (env, path) -> ( + Locate.log ~title:"debug" "found type: %s" (Path.name path); + let config = + Locate. + { mconfig = Mpipeline.final_config pipeline; + ml_or_mli = `MLI; + traverse_aliases = true + } + in + match Locate.from_path ~config ~env ~local_defs ~namespace:Type path with + | `Builtin (_, s) -> `Builtin s + | `Not_in_env _ as s -> s + | `Not_found _ as s -> s + | `Found { file; location; _ } -> `Found (Some file, location.loc_start) + | `File_not_found { file = reason; _ } -> `File_not_found reason) end | Locate_types pos -> ( let typer = Mpipeline.typer_result pipeline in @@ -589,21 +581,20 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function traverse_aliases = true } in - begin - match Locate.from_string ~config ~env ~local_defs ~pos path with - | `Found { file; location; _ } -> - Locate.log ~title:"result" "found: %s" file; - `Found (Some file, location.loc_start) - | `Missing_labels_namespace -> - (* Can't happen because we haven't passed a namespace as input. *) - assert false - | `Builtin (_, s) -> - Locate.log ~title:"result" "found builtin %s" s; - `Builtin s - | `File_not_found { file = reason; _ } -> `File_not_found reason - | (`Not_found _ | `At_origin | `Not_in_env _) as otherwise -> - Locate.log ~title:"result" "not found"; - otherwise + begin match Locate.from_string ~config ~env ~local_defs ~pos path with + | `Found { file; location; _ } -> + Locate.log ~title:"result" "found: %s" file; + `Found (Some file, location.loc_start) + | `Missing_labels_namespace -> + (* Can't happen because we haven't passed a namespace as input. *) + assert false + | `Builtin (_, s) -> + Locate.log ~title:"result" "found builtin %s" s; + `Builtin s + | `File_not_found { file = reason; _ } -> `File_not_found reason + | (`Not_found _ | `At_origin | `Not_in_env _) as otherwise -> + Locate.log ~title:"result" "not found"; + otherwise end | Jump (target, pos) -> let typer = Mpipeline.typer_result pipeline in @@ -647,15 +638,14 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function in Destruct.log ~title:"nodes after" "%a" Logger.json (fun () -> `List (List.map nodes ~f:dump_node)); - begin - match nodes with - | [] -> raise Destruct.Nothing_to_do - | (env, node) :: parents -> - let source = Mpipeline.input_source pipeline in - let config = Mpipeline.final_config pipeline in - let verbosity = verbosity pipeline in - Printtyp.wrap_printing_env env ~verbosity @@ fun () -> - Destruct.node config source node (List.map ~f:snd parents) + begin match nodes with + | [] -> raise Destruct.Nothing_to_do + | (env, node) :: parents -> + let source = Mpipeline.input_source pipeline in + let config = Mpipeline.final_config pipeline in + let verbosity = verbosity pipeline in + Printtyp.wrap_printing_env env ~verbosity @@ fun () -> + Destruct.node config source node (List.map ~f:snd parents) end | Holes -> let typer = Mpipeline.typer_result pipeline in @@ -692,21 +682,20 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function let typedtree = Mtyper.get_typedtree typer in let pos = Mpipeline.get_lexing_pos pipeline pos in let structures = Mbrowse.enclosing pos [ Mbrowse.of_typedtree typedtree ] in - begin - match structures with - | ( _, - (Browse_raw.Module_expr { mod_desc = Tmod_typed_hole; _ } as - node_for_loc) ) - :: (_, node) - :: _parents -> - let loc = Mbrowse.node_loc node_for_loc in - (loc, Construct.node ~config ~keywords ?depth ~values_scope node) - | (_, (Browse_raw.Expression { exp_desc = Texp_typed_hole; _ } as node)) - :: _parents -> - let loc = Mbrowse.node_loc node in - (loc, Construct.node ~config ~keywords ?depth ~values_scope node) - | _ :: _ -> raise Construct.Not_a_hole - | [] -> raise No_nodes + begin match structures with + | ( _, + (Browse_raw.Module_expr { mod_desc = Tmod_typed_hole; _ } as + node_for_loc) ) + :: (_, node) + :: _parents -> + let loc = Mbrowse.node_loc node_for_loc in + (loc, Construct.node ~config ~keywords ?depth ~values_scope node) + | (_, (Browse_raw.Expression { exp_desc = Texp_typed_hole; _ } as node)) + :: _parents -> + let loc = Mbrowse.node_loc node in + (loc, Construct.node ~config ~keywords ?depth ~values_scope node) + | _ :: _ -> raise Construct.Not_a_hole + | [] -> raise No_nodes end | Outline -> let typer = Mpipeline.typer_result pipeline in @@ -756,13 +745,12 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function let first_syntax_error = ref Lexing.dummy_pos in let filter_typer_error exn = let result = filter_error exn in - begin - match result with - | Some ({ Location.source = Location.Parser; _ } as err) - when !first_syntax_error = Lexing.dummy_pos - || Lexing.compare_pos !first_syntax_error (error_start err) > 0 - -> first_syntax_error := error_start err - | _ -> () + begin match result with + | Some ({ Location.source = Location.Parser; _ } as err) + when !first_syntax_error = Lexing.dummy_pos + || Lexing.compare_pos !first_syntax_error (error_start err) > 0 -> + first_syntax_error := error_start err + | _ -> () end; result in @@ -772,14 +760,13 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function | Msupport.Warning _ as exn -> filter_error exn | exn -> let result = filter_error exn in - begin - match result with - | None -> () - | Some err -> - if - !first_syntax_error = Lexing.dummy_pos - || Lexing.compare_pos !first_syntax_error (error_start err) > 0 - then first_syntax_error := error_start err + begin match result with + | None -> () + | Some err -> + if + !first_syntax_error = Lexing.dummy_pos + || Lexing.compare_pos !first_syntax_error (error_start err) > 0 + then first_syntax_error := error_start err end; result in @@ -831,14 +818,13 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function | Extension_list kind -> let config = Mpipeline.final_config pipeline in let enabled = Mconfig.(config.merlin.extensions) in - begin - match kind with - | `All -> Extension.all - | `Enabled -> enabled - | `Disabled -> - List.fold_left - ~f:(fun exts ext -> List.remove ext exts) - ~init:Extension.all enabled + begin match kind with + | `All -> Extension.all + | `Enabled -> enabled + | `Disabled -> + List.fold_left + ~f:(fun exts ext -> List.remove ext exts) + ~init:Extension.all enabled end | Path_list `Build -> let config = Mpipeline.final_config pipeline in @@ -873,12 +859,11 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function let start = Mpipeline.get_lexing_pos pipeline start and stop = Mpipeline.get_lexing_pos pipeline stop in let typer_result = Mpipeline.typer_result pipeline in - begin - match Mtyper.get_typedtree typer_result with - | `Interface _ -> [] - | `Implementation structure -> - Inlay_hints.of_structure ~hint_let_binding ~hint_pattern_binding - ~hint_function_params ~avoid_ghost_location ~start ~stop structure + begin match Mtyper.get_typedtree typer_result with + | `Interface _ -> [] + | `Implementation structure -> + Inlay_hints.of_structure ~hint_let_binding ~hint_pattern_binding + ~hint_function_params ~avoid_ghost_location ~start ~stop structure end | Signature_help { position; _ } -> ( (* Todo: additionnal contextual information could help us provide better diff --git a/src/frontend/test/ocamlmerlin_test.ml b/src/frontend/test/ocamlmerlin_test.ml index 524c1826f..0ed6d01ad 100644 --- a/src/frontend/test/ocamlmerlin_test.ml +++ b/src/frontend/test/ocamlmerlin_test.ml @@ -168,27 +168,25 @@ let rec run_tests indent = function and run_test indent = function | Single (name, f) -> Printf.printf "%s%s:\t%!" indent name; - begin - match f () with - | () -> - incr passed; - Printf.printf "OK\n%!" - | exception exn -> - let bt = Printexc.get_backtrace () in - incr failed; - Printf.printf "KO\n%!"; - Printf.eprintf "%sTest %s failed with exception:\n%s%s\n%!" indent name - indent - (match exn with - | Failure str -> str - | exn -> Printexc.to_string exn); - begin - match Location.error_of_exn exn with - | None | Some `Already_displayed -> () - | Some (`Ok { Location.msg; loc }) -> - Printf.eprintf "%sError message:\n%s\n%!" indent msg - end; - Printf.eprintf "%sBacktrace:\n%s\n%!" indent bt + begin match f () with + | () -> + incr passed; + Printf.printf "OK\n%!" + | exception exn -> + let bt = Printexc.get_backtrace () in + incr failed; + Printf.printf "KO\n%!"; + Printf.eprintf "%sTest %s failed with exception:\n%s%s\n%!" indent name + indent + (match exn with + | Failure str -> str + | exn -> Printexc.to_string exn); + begin match Location.error_of_exn exn with + | None | Some `Already_displayed -> () + | Some (`Ok { Location.msg; loc }) -> + Printf.eprintf "%sError message:\n%s\n%!" indent msg + end; + Printf.eprintf "%sBacktrace:\n%s\n%!" indent bt end | Group (name, tests) -> Printf.printf "%s-> %s\n" indent name; diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 76593b826..9455fecbe 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -828,10 +828,9 @@ let unitname t = | Some name -> Misc.unitname name | None -> let basename = Misc.unitname t.query.filename in - begin - match t.merlin.wrapping_prefix with - | Some prefix -> prefix ^ basename - | None -> basename + begin match t.merlin.wrapping_prefix with + | Some prefix -> prefix ^ basename + | None -> basename end let intf_or_impl t = diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index 0a42a1d3f..744b82dbe 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -321,12 +321,12 @@ let get_config { workdir; process_dir; configurator } path_abs = let path_rel = String.chop_prefix ~prefix:p.initial_cwd path_abs |> Option.map ~f:(fun path -> - (* We need to remove the leading path separator after chopping. + (* We need to remove the leading path separator after chopping. There is one case where no separator is left: when [initial_cwd] was the root of the filesystem *) - if String.length path > 0 && path.[0] = Filename.dir_sep.[0] then - String.drop 1 path - else path) + if String.length path > 0 && path.[0] = Filename.dir_sep.[0] then + String.drop 1 path + else path) in let path = diff --git a/src/kernel/mppx.ml b/src/kernel/mppx.ml index 2a26d5384..8ac0edb8c 100644 --- a/src/kernel/mppx.ml +++ b/src/kernel/mppx.ml @@ -12,11 +12,10 @@ let with_include_dir ~visible_path ~hidden_path f = Clflags.include_dirs := visible_path; Clflags.hidden_include_dirs := hidden_path; let result = - begin - try f () - with e -> - restore (); - raise e + begin try f () + with e -> + restore (); + raise e end in restore (); diff --git a/src/kernel/mreader.ml b/src/kernel/mreader.ml index d84839d3f..e06d72318 100644 --- a/src/kernel/mreader.ml +++ b/src/kernel/mreader.ml @@ -135,15 +135,14 @@ let print_pretty config source tree = | None -> let ppf, to_string = Std.Format.to_string () in let open Extend_protocol.Reader in - begin - match tree with - | Pretty_case_list x -> Pprintast.case_list ppf x - | Pretty_core_type x -> Pprintast.core_type ppf x - | Pretty_expression x -> Pprintast.expression ppf x - | Pretty_pattern x -> Pprintast.pattern ppf x - | Pretty_signature x -> Pprintast.signature ppf x - | Pretty_structure x -> Pprintast.structure ppf x - | Pretty_toplevel_phrase x -> Pprintast.toplevel_phrase ppf x + begin match tree with + | Pretty_case_list x -> Pprintast.case_list ppf x + | Pretty_core_type x -> Pprintast.core_type ppf x + | Pretty_expression x -> Pprintast.expression ppf x + | Pretty_pattern x -> Pprintast.pattern ppf x + | Pretty_signature x -> Pprintast.signature ppf x + | Pretty_structure x -> Pprintast.structure ppf x + | Pretty_toplevel_phrase x -> Pprintast.toplevel_phrase ppf x end; to_string () diff --git a/src/kernel/mreader_explain.ml b/src/kernel/mreader_explain.ml index 6e7cbcb8f..704f9f58c 100644 --- a/src/kernel/mreader_explain.ml +++ b/src/kernel/mreader_explain.ml @@ -57,13 +57,12 @@ let explain env (unexpected, startp, endp) popped shifted = | None -> return None | Some (Element (st, _, startp, endp)) -> ( if closing_st st then incr closed; - begin - match opening_st st with - | None -> () - | Some st -> - if !closed = 0 && !unclosed = None then - unclosed := Some (st, mkloc startp endp) - else decr closed + begin match opening_st st with + | None -> () + | Some st -> + if !closed = 0 && !unclosed = None then + unclosed := Some (st, mkloc startp endp) + else decr closed end; match Parser_explain.named_item_at (number st) with | name -> return (Some (name, mkloc startp endp)) diff --git a/src/kernel/mreader_lexer.ml b/src/kernel/mreader_lexer.ml index 28d77d259..07b6c91be 100644 --- a/src/kernel/mreader_lexer.ml +++ b/src/kernel/mreader_lexer.ml @@ -331,11 +331,10 @@ let for_completion t pos = | (Triple (token, _, loc_end) as item) :: _ as items when Lexing.compare_pos pos loc_end = 0 -> check_label item; - begin - match token with - (* Already on identifier, no need to introduce *) - | UIDENT _ | LIDENT _ -> raise Exit - | _ -> (acc, items) + begin match token with + (* Already on identifier, no need to introduce *) + | UIDENT _ | LIDENT _ -> raise Exit + | _ -> (acc, items) end | items -> (acc, items) in diff --git a/src/kernel/mreader_recover.ml b/src/kernel/mreader_recover.ml index d13314cbb..da526afc0 100644 --- a/src/kernel/mreader_recover.ml +++ b/src/kernel/mreader_recover.ml @@ -199,11 +199,10 @@ struct in let v = Recovery.default_value loc sym in let token = (Recovery.token_of_terminal t v, endp, endp) in - begin - match feed_token ~allow_reduction:true token env with - | `Fail -> assert false - | `Accept v -> raise (E.Result v) - | `Recovered (_, env) -> env + begin match feed_token ~allow_reduction:true token env with + | `Fail -> assert false + | `Accept v -> raise (E.Result v) + | `Recovered (_, env) -> env end | Recovery.Sub actions -> log ~title:"enter Sub" ""; diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index 2a6aec6bc..46e38d5b0 100644 --- a/src/ocaml/merlin_specific/browse_raw.ml +++ b/src/ocaml/merlin_specific/browse_raw.ml @@ -221,8 +221,8 @@ let has_attr ~name node = let attrs = node_attributes node in List.exists ~f:(fun a -> - let str, _ = Ast_helper.Attr.as_tuple a in - str.Location.txt = name) + let str, _ = Ast_helper.Attr.as_tuple a in + str.Location.txt = name) attrs let node_merlin_loc loc0 node = @@ -338,7 +338,7 @@ let of_pattern_desc (type k) (desc : k pattern_desc) = | Tpat_record (ls, _) -> list_fold (fun (lid_loc, desc, p) -> - of_pat_record_field p lid_loc desc ** of_pattern p) + of_pat_record_field p lid_loc desc ** of_pattern p) ls | Tpat_or (p1, p2, _) -> of_pattern p1 ** of_pattern p2 @@ -358,17 +358,16 @@ let rec of_expression_desc loc = function | Texp_apply (e, ls) -> of_expression e ** list_fold - (function - | _, Omitted () -> id_fold - | _, Arg e -> of_expression e) - ls + (function + | _, Omitted () -> id_fold + | _, Arg e -> of_expression e) + ls | Texp_match (e, cs, vs, _) -> of_expression e ** list_fold of_case cs ** list_fold of_case vs | Texp_try (e, cs, _) -> of_expression e ** list_fold of_case cs | Texp_tuple es -> list_fold of_expression (List.map ~f:snd es) (* todo labels ? *) - | Texp_construct (_, _, es) | Texp_array (_, es) -> - list_fold of_expression es + | Texp_construct (_, _, es) | Texp_array (_, es) -> list_fold of_expression es | Texp_variant (_, Some e) | Texp_assert (e, _) | Texp_lazy e @@ -545,8 +544,8 @@ and of_core_type_desc = function | Ttyp_object (cts, _) -> list_fold (fun of_ -> - match of_.of_desc with - | OTtag (_, ct) | OTinherit ct -> of_core_type ct) + match of_.of_desc with + | OTtag (_, ct) | OTinherit ct -> of_core_type ct) cts | Ttyp_poly (_, ct) | Ttyp_alias (ct, _) -> of_core_type ct | Ttyp_variant (rfs, _, _) -> list_fold (fun rf -> app (Row_field rf)) rfs @@ -596,9 +595,9 @@ let of_node = function | Structure { str_items; str_final_env } -> list_fold_with_next (fun next item -> - match next with - | None -> app (Structure_item (item, str_final_env)) - | Some item' -> app (Structure_item (item, item'.str_env))) + match next with + | None -> app (Structure_item (item, str_final_env)) + | Some item' -> app (Structure_item (item, item'.str_env))) str_items | Structure_item ({ str_desc }, _) -> of_structure_item_desc str_desc | Module_binding mb -> @@ -609,9 +608,9 @@ let of_node = function | Signature { sig_items; sig_final_env } -> list_fold_with_next (fun next item -> - match next with - | None -> app (Signature_item (item, sig_final_env)) - | Some item' -> app (Signature_item (item, item'.sig_env))) + match next with + | None -> app (Signature_item (item, sig_final_env)) + | Some item' -> app (Signature_item (item, item'.sig_env))) sig_items | Signature_item ({ sig_desc }, _) -> of_signature_item_desc sig_desc | Module_declaration md -> @@ -628,10 +627,10 @@ let of_node = function | Package_type { tpt_cstrs } -> list_fold (fun (_, ct) -> of_core_type ct) tpt_cstrs | Row_field rf -> begin - match rf.rf_desc with - | Ttag (_, _, cts) -> list_fold of_core_type cts - | Tinherit ct -> of_core_type ct - end + match rf.rf_desc with + | Ttag (_, _, cts) -> list_fold of_core_type cts + | Tinherit ct -> of_core_type ct + end | Value_description { val_desc } -> of_core_type val_desc | Type_declaration { typ_params; typ_cstrs; typ_kind; typ_manifest } -> let of_typ_cstrs (ct1, ct2, _) = of_core_type ct1 ** of_core_type ct2 in @@ -789,7 +788,7 @@ let expression_paths { Typedtree.exp_desc; exp_extra; _ } = | Texp_override (_, ps) -> List.map ~f:(fun (id, loc, _) -> - (reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt))) + (reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt))) ps | Texp_letmodule (Some id, loc, _, _, _) -> [ (reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt) ] @@ -836,7 +835,7 @@ let structure_item_paths { Typedtree.str_desc } = | Tstr_class_type cls -> List.map ~f:(fun (id, loc, _) -> - (reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt))) + (reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt))) cls | Tstr_open od -> module_expr_paths od.open_expr | _ -> [] @@ -910,8 +909,8 @@ let node_paths_full = let node_paths t = List.map (node_paths_full t) ~f:fst let node_paths_and_longident t = List.filter_map (node_paths_full t) ~f:(function - | _, None -> None - | p, Some lid -> Some (p, lid)) + | _, None -> None + | p, Some lid -> Some (p, lid)) let node_is_constructor = function | Constructor_declaration decl -> diff --git a/src/ocaml/typing/msupport.ml b/src/ocaml/typing/msupport.ml index 2491259ff..ab2011ecd 100644 --- a/src/ocaml/typing/msupport.ml +++ b/src/ocaml/typing/msupport.ml @@ -140,16 +140,15 @@ let rec get_saved_types_from_attributes = function let attr, str = Ast_helper.Attr.as_tuple attr in if attr = Saved_parts.attribute then let open Parsetree in - begin - match str with - | PStr - ({ pstr_desc = - Pstr_eval - ({ pexp_desc = Pexp_constant { pconst_desc = key; _ }; _ }, _); - _ - } - :: _) -> Saved_parts.find key - | _ -> [] + begin match str with + | PStr + ({ pstr_desc = + Pstr_eval + ({ pexp_desc = Pexp_constant { pconst_desc = key; _ }; _ }, _); + _ + } + :: _) -> Saved_parts.find key + | _ -> [] end else get_saved_types_from_attributes attrs @@ -163,10 +162,9 @@ let with_saved_types ?warning_attribute ?save_part f = Cmt_format.set_saved_types []; try let result = with_warning_attribute ?warning_attribute f in - begin - match save_part with - | None -> () - | Some f -> Cmt_format.set_saved_types (f result :: saved_types) + begin match save_part with + | None -> () + | Some f -> Cmt_format.set_saved_types (f result :: saved_types) end; result with exn -> diff --git a/src/sherlodoc/type_distance.ml b/src/sherlodoc/type_distance.ml index 7a3481dd1..e325de751 100644 --- a/src/sherlodoc/type_distance.ml +++ b/src/sherlodoc/type_distance.ml @@ -52,15 +52,15 @@ let make_path t = let prefix = Tyname constr :: prefix in args |> List.mapi (fun position arg -> - let prefix = Argument { position; length } :: prefix in - aux prefix arg) + let prefix = Argument { position; length } :: prefix in + aux prefix arg) |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] | Type_expr.Tuple args -> let length = List.length args in args |> List.mapi (fun position arg -> - let prefix = Product { position; length } :: prefix in - aux prefix arg) + let prefix = Product { position; length } :: prefix in + aux prefix arg) |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] in List.map List.rev (aux [] t) @@ -125,8 +125,8 @@ let distance xs ys = let make_array list = list |> Array.of_list |> Array.map (fun li -> - let li = List.mapi (fun i x -> (x, i)) li in - List.sort Stdlib.compare li) + let li = List.mapi (fun i x -> (x, i)) li in + List.sort Stdlib.compare li) let init_heuristic list = let used = Array.make List.(length @@ hd list) false in diff --git a/src/utils/logger.ml b/src/utils/logger.ml index f695e7eb0..f4cc12c54 100644 --- a/src/utils/logger.ml +++ b/src/utils/logger.ml @@ -65,11 +65,10 @@ let fmt_handle = Format.formatter_of_buffer fmt_buffer let fmt () f = Buffer.reset fmt_buffer; - begin - match f fmt_handle with - | () -> () - | exception exn -> - Format.fprintf fmt_handle "@\nException: %s" (Printexc.to_string exn) + begin match f fmt_handle with + | () -> () + | exception exn -> + Format.fprintf fmt_handle "@\nException: %s" (Printexc.to_string exn) end; Format.pp_print_flush fmt_handle (); let msg = Buffer.contents fmt_buffer in diff --git a/src/utils/sexp.ml b/src/utils/sexp.ml index 85f4f7b18..8955f2717 100644 --- a/src/utils/sexp.ml +++ b/src/utils/sexp.ml @@ -45,23 +45,22 @@ let unescaped str = match str.[!i] with | '\\' -> incr i; - begin - match str.[!i] with - | 'n' -> Buffer.add_char buf '\n' - | 'r' -> Buffer.add_char buf '\r' - | 't' -> Buffer.add_char buf '\t' - | 'x' -> - let c0 = Char.code str.[!i + 1] in - let c1 = Char.code str.[!i + 2] in - Buffer.add_char buf (Char.chr (c0 * 16 lor c1)); - i := !i + 2 - | '0' .. '9' -> - let c0 = Char.code str.[!i + 1] in - let c1 = Char.code str.[!i + 2] in - let c2 = Char.code str.[!i + 3] in - Buffer.add_char buf (Char.chr (c0 * 64 lor (c1 * 8) lor c2)); - i := !i + 2 - | c -> Buffer.add_char buf c + begin match str.[!i] with + | 'n' -> Buffer.add_char buf '\n' + | 'r' -> Buffer.add_char buf '\r' + | 't' -> Buffer.add_char buf '\t' + | 'x' -> + let c0 = Char.code str.[!i + 1] in + let c1 = Char.code str.[!i + 2] in + Buffer.add_char buf (Char.chr (c0 * 16 lor c1)); + i := !i + 2 + | '0' .. '9' -> + let c0 = Char.code str.[!i + 1] in + let c1 = Char.code str.[!i + 2] in + let c2 = Char.code str.[!i + 3] in + Buffer.add_char buf (Char.chr (c0 * 64 lor (c1 * 8) lor c2)); + i := !i + 2 + | c -> Buffer.add_char buf c end; incr i | c -> @@ -129,10 +128,9 @@ let read_sexp getch = | ' ' | '\t' | '\n' -> aux (getch ()) | _ -> failwith "Invalid parse" in - ( begin - match next with - | Some c -> aux c - | None -> aux (getch ()) + ( begin match next with + | Some c -> aux c + | None -> aux (getch ()) end, None ) | c -> diff --git a/src/utils/std.ml b/src/utils/std.ml index 751a15c22..480e13c49 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -404,12 +404,12 @@ module String = struct let l' = String.length s in l' >= l && - try - for i = 0 to pred l do - if s.[i] <> by.[i] then raise Not_found - done; - true - with Not_found -> false + try + for i = 0 to pred l do + if s.[i] <> by.[i] then raise Not_found + done; + true + with Not_found -> false (* Drop characters from beginning of string *) let drop n s = sub s ~pos:n ~len:(length s - n) @@ -703,18 +703,17 @@ end = struct let l = String.length pattern in let i = ref 0 in while !i < l do - begin - match pattern.[!i] with - | '\\' -> - incr i; - if !i < l then Buffer.add_char chunk pattern.[!i] - | '*' -> - flush (); - Buffer.add_string regexp ".*" - | '?' -> - flush (); - Buffer.add_char regexp '.' - | x -> Buffer.add_char chunk x + begin match pattern.[!i] with + | '\\' -> + incr i; + if !i < l then Buffer.add_char chunk pattern.[!i] + | '*' -> + flush (); + Buffer.add_string regexp ".*" + | '?' -> + flush (); + Buffer.add_char regexp '.' + | x -> Buffer.add_char chunk x end; incr i done; @@ -857,25 +856,21 @@ end * - modules_in_path ~ext:".mli" ["."] returns ["A"] *) let modules_in_path ~ext path = let seen = Hashtbl.create 7 in - List.fold_left ~init:[] path - ~f: - begin - fun results dir -> - try - Array.fold_left - begin - fun results file -> - if Filename.check_suffix file ext then - let name = Filename.chop_extension file in - if Hashtbl.mem seen name then results - else ( - Hashtbl.add seen name (); - String.capitalize name :: results) - else results - end - results (Sys.readdir dir) - with Sys_error _ -> results - end + List.fold_left ~init:[] path ~f:begin fun results dir -> + try + Array.fold_left + begin fun results file -> + if Filename.check_suffix file ext then + let name = Filename.chop_extension file in + if Hashtbl.mem seen name then results + else ( + Hashtbl.add seen name (); + String.capitalize name :: results) + else results + end + results (Sys.readdir dir) + with Sys_error _ -> results + end let file_contents filename = let ic = open_in filename in