diff --git a/src/ocaml/.ocamlformat-enable b/src/ocaml/.ocamlformat-enable new file mode 100644 index 000000000..23f379d2c --- /dev/null +++ b/src/ocaml/.ocamlformat-enable @@ -0,0 +1 @@ +merlin_specific/** diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index 4d6fe4ac7..33040443b 100644 --- a/src/ocaml/merlin_specific/browse_raw.ml +++ b/src/ocaml/merlin_specific/browse_raw.ml @@ -1,30 +1,30 @@ (* {{{ Copying *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2017 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2017 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) [@@@ocaml.warning "-9"] @@ -36,169 +36,194 @@ open Typedtree type node = | Dummy - | Pattern : _ general_pattern -> node - | Expression of expression - | Case : _ case -> node - | Class_expr of class_expr - | Class_structure of class_structure - | Class_field of class_field - | Class_field_kind of class_field_kind - | Module_expr of module_expr - | Module_type_constraint of module_type_constraint - | Structure of structure - | Signature of signature - | Structure_item of structure_item * Env.t - | Signature_item of signature_item * Env.t - | Module_binding of module_binding - | Value_binding of value_binding - | Module_type of module_type - | Module_declaration of module_declaration - | Module_type_declaration of module_type_declaration - | With_constraint of with_constraint - | Core_type of core_type - | Package_type of package_type - | Row_field of row_field - | Value_description of value_description - | Type_declaration of type_declaration - | Type_kind of type_kind - | Type_extension of type_extension - | Extension_constructor of extension_constructor - | Label_declaration of label_declaration - | Constructor_declaration of constructor_declaration - | Class_type of class_type - | Class_signature of class_signature - | Class_type_field of class_type_field - | Class_declaration of class_declaration - | Class_description of class_description - | Class_type_declaration of class_type_declaration - | Binding_op of binding_op - - | Include_description of include_description - | Include_declaration of include_declaration - | Open_description of open_description - | Open_declaration of open_declaration - - | Method_call of expression * meth * Location.t - | Record_field of [`Expression of expression | `Pattern of pattern] - * Types.label_description - * Longident.t Location.loc - | Module_binding_name of module_binding - | Module_declaration_name of module_declaration + | Pattern : _ general_pattern -> node + | Expression of expression + | Case : _ case -> node + | Class_expr of class_expr + | Class_structure of class_structure + | Class_field of class_field + | Class_field_kind of class_field_kind + | Module_expr of module_expr + | Module_type_constraint of module_type_constraint + | Structure of structure + | Signature of signature + | Structure_item of structure_item * Env.t + | Signature_item of signature_item * Env.t + | Module_binding of module_binding + | Value_binding of value_binding + | Module_type of module_type + | Module_declaration of module_declaration + | Module_type_declaration of module_type_declaration + | With_constraint of with_constraint + | Core_type of core_type + | Package_type of package_type + | Row_field of row_field + | Value_description of value_description + | Type_declaration of type_declaration + | Type_kind of type_kind + | Type_extension of type_extension + | Extension_constructor of extension_constructor + | Label_declaration of label_declaration + | Constructor_declaration of constructor_declaration + | Class_type of class_type + | Class_signature of class_signature + | Class_type_field of class_type_field + | Class_declaration of class_declaration + | Class_description of class_description + | Class_type_declaration of class_type_declaration + | Binding_op of binding_op + | Include_description of include_description + | Include_declaration of include_declaration + | Open_description of open_description + | Open_declaration of open_declaration + | Method_call of expression * meth * Location.t + | Record_field of + [ `Expression of expression | `Pattern of pattern ] + * Types.label_description + * Longident.t Location.loc + | Module_binding_name of module_binding + | Module_declaration_name of module_declaration | Module_type_declaration_name of module_type_declaration let node_update_env env0 = function - | Pattern {pat_env = env} | Expression {exp_env = env} - | Class_expr {cl_env = env} | Method_call ({exp_env = env}, _, _) - | Record_field (`Expression {exp_env = env}, _, _) - | Record_field (`Pattern {pat_env = env}, _, _) - | Module_expr {mod_env = env} | Module_type {mty_env = env} - | Structure_item (_, env) | Signature_item (_, env) - | Core_type {ctyp_env = env} | Class_type {cltyp_env = env} - -> env - | Dummy | Case _ - | Class_structure _ | Class_signature _ - | Class_field _ | Class_field_kind _ - | Type_extension _ | Extension_constructor _ - | Package_type _ | Row_field _ - | Type_declaration _ | Type_kind _ - | Module_binding _ | Module_declaration _ - | Module_binding_name _ | Module_declaration_name _ - | Module_type_declaration _ | Module_type_constraint _ - | Module_type_declaration_name _ | With_constraint _ - | Structure _ | Signature _ - | Value_description _ | Value_binding _ - | Constructor_declaration _ | Label_declaration _ - | Class_declaration _ | Class_description _ - | Class_type_declaration _ | Class_type_field _ - | Include_description _ | Include_declaration _ - | Open_description _ | Open_declaration _ - | Binding_op _ - -> env0 + | Pattern { pat_env = env } + | Expression { exp_env = env } + | Class_expr { cl_env = env } + | Method_call ({ exp_env = env }, _, _) + | Record_field (`Expression { exp_env = env }, _, _) + | Record_field (`Pattern { pat_env = env }, _, _) + | Module_expr { mod_env = env } + | Module_type { mty_env = env } + | Structure_item (_, env) + | Signature_item (_, env) + | Core_type { ctyp_env = env } + | Class_type { cltyp_env = env } -> env + | Dummy + | Case _ + | Class_structure _ + | Class_signature _ + | Class_field _ + | Class_field_kind _ + | Type_extension _ + | Extension_constructor _ + | Package_type _ + | Row_field _ + | Type_declaration _ + | Type_kind _ + | Module_binding _ + | Module_declaration _ + | Module_binding_name _ + | Module_declaration_name _ + | Module_type_declaration _ + | Module_type_constraint _ + | Module_type_declaration_name _ + | With_constraint _ + | Structure _ + | Signature _ + | Value_description _ + | Value_binding _ + | Constructor_declaration _ + | Label_declaration _ + | Class_declaration _ + | Class_description _ + | Class_type_declaration _ + | Class_type_field _ + | Include_description _ + | Include_declaration _ + | Open_description _ + | Open_declaration _ + | Binding_op _ -> env0 let node_real_loc loc0 = function - | Expression {exp_loc = loc} - | Pattern {pat_loc = loc} - | Method_call (_, _, loc) - | Record_field (_, _, {loc}) - | Class_expr {cl_loc = loc} - | Module_expr {mod_loc = loc} - | Structure_item ({str_loc = loc}, _) - | Signature_item ({sig_loc = loc}, _) - | Module_type {mty_loc = loc} - | Core_type {ctyp_loc = loc} - | Class_type {cltyp_loc = loc} - | Class_field {cf_loc = loc} - | Module_binding {mb_loc = loc} - | Module_declaration {md_loc = loc} - | Module_type_declaration {mtd_loc = loc} - | Value_description {val_loc = loc} - | Value_binding {vb_loc = loc} - | Type_declaration {typ_loc = loc} - | Label_declaration {ld_loc = loc} - | Constructor_declaration {cd_loc = loc} - | Class_type_field {ctf_loc = loc} - | Class_declaration {ci_loc = loc} - | Class_description {ci_loc = loc} - | Class_type_declaration {ci_loc = loc} - | Extension_constructor {ext_loc = loc} - | Include_description {incl_loc = loc} - | Include_declaration {incl_loc = loc} - | Open_description {open_loc = loc} - | Open_declaration {open_loc = loc} - | Binding_op {bop_op_name = {loc}} - -> loc - | Module_type_declaration_name {mtd_name = loc} - -> loc.Location.loc - | Module_declaration_name {md_name = loc} - | Module_binding_name {mb_name = loc} - -> loc.Location.loc - | Structure _ | Signature _ | Case _ | Class_structure _ | Type_extension _ - | Class_field_kind _ | Module_type_constraint _ | With_constraint _ - | Row_field _ | Type_kind _ | Class_signature _ | Package_type _ - | Dummy - -> loc0 + | Expression { exp_loc = loc } + | Pattern { pat_loc = loc } + | Method_call (_, _, loc) + | Record_field (_, _, { loc }) + | Class_expr { cl_loc = loc } + | Module_expr { mod_loc = loc } + | Structure_item ({ str_loc = loc }, _) + | Signature_item ({ sig_loc = loc }, _) + | Module_type { mty_loc = loc } + | Core_type { ctyp_loc = loc } + | Class_type { cltyp_loc = loc } + | Class_field { cf_loc = loc } + | Module_binding { mb_loc = loc } + | Module_declaration { md_loc = loc } + | Module_type_declaration { mtd_loc = loc } + | Value_description { val_loc = loc } + | Value_binding { vb_loc = loc } + | Type_declaration { typ_loc = loc } + | Label_declaration { ld_loc = loc } + | Constructor_declaration { cd_loc = loc } + | Class_type_field { ctf_loc = loc } + | Class_declaration { ci_loc = loc } + | Class_description { ci_loc = loc } + | Class_type_declaration { ci_loc = loc } + | Extension_constructor { ext_loc = loc } + | Include_description { incl_loc = loc } + | Include_declaration { incl_loc = loc } + | Open_description { open_loc = loc } + | Open_declaration { open_loc = loc } + | Binding_op { bop_op_name = { loc } } -> loc + | Module_type_declaration_name { mtd_name = loc } -> loc.Location.loc + | Module_declaration_name { md_name = loc } + | Module_binding_name { mb_name = loc } -> loc.Location.loc + | Structure _ + | Signature _ + | Case _ + | Class_structure _ + | Type_extension _ + | Class_field_kind _ + | Module_type_constraint _ + | With_constraint _ + | Row_field _ + | Type_kind _ + | Class_signature _ + | Package_type _ + | Dummy -> loc0 let node_attributes = function - | Expression exp -> exp.exp_attributes - | Pattern pat -> pat.pat_attributes - | Class_expr cl -> cl.cl_attributes - | Class_field cf -> cf.cf_attributes - | Module_expr me -> me.mod_attributes - | Structure_item ({str_desc = Tstr_eval (_,attr)},_) -> attr - | Structure_item ({str_desc = Tstr_attribute a},_) -> [a] - | Signature_item ({sig_desc = Tsig_attribute a},_) -> [a] - | Module_binding mb -> mb.mb_attributes - | Value_binding vb -> vb.vb_attributes - | Module_type mt -> mt.mty_attributes + | Expression exp -> exp.exp_attributes + | Pattern pat -> pat.pat_attributes + | Class_expr cl -> cl.cl_attributes + | Class_field cf -> cf.cf_attributes + | Module_expr me -> me.mod_attributes + | Structure_item ({ str_desc = Tstr_eval (_, attr) }, _) -> attr + | Structure_item ({ str_desc = Tstr_attribute a }, _) -> [ a ] + | Signature_item ({ sig_desc = Tsig_attribute a }, _) -> [ a ] + | Module_binding mb -> mb.mb_attributes + | Value_binding vb -> vb.vb_attributes + | Module_type mt -> mt.mty_attributes | Module_declaration md -> md.md_attributes | Module_type_declaration mtd -> mtd.mtd_attributes - | Open_description o -> o.open_attributes + | Open_description o -> o.open_attributes | Include_declaration i -> i.incl_attributes | Include_description i -> i.incl_attributes - | Core_type ct -> ct.ctyp_attributes - | Row_field rf -> rf.rf_attributes - | Value_description vd -> vd.val_attributes - | Type_declaration td -> td.typ_attributes - | Label_declaration ld -> ld.ld_attributes + | Core_type ct -> ct.ctyp_attributes + | Row_field rf -> rf.rf_attributes + | Value_description vd -> vd.val_attributes + | Type_declaration td -> td.typ_attributes + | Label_declaration ld -> ld.ld_attributes | Constructor_declaration cd -> cd.cd_attributes - | Type_extension te -> te.tyext_attributes + | Type_extension te -> te.tyext_attributes | Extension_constructor ec -> ec.ext_attributes - | Class_type ct -> ct.cltyp_attributes - | Class_type_field ctf -> ctf.ctf_attributes + | Class_type ct -> ct.cltyp_attributes + | Class_type_field ctf -> ctf.ctf_attributes | Class_declaration ci -> ci.ci_attributes | Class_description ci -> ci.ci_attributes | Class_type_declaration ci -> ci.ci_attributes - | Method_call (obj,_,_) -> obj.exp_attributes - | Record_field (`Expression obj,_,_) -> obj.exp_attributes - | Record_field (`Pattern obj,_,_) -> obj.pat_attributes + | Method_call (obj, _, _) -> obj.exp_attributes + | Record_field (`Expression obj, _, _) -> obj.exp_attributes + | Record_field (`Pattern obj, _, _) -> obj.pat_attributes | _ -> [] 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 - ) attrs + List.exists + ~f:(fun a -> + let str, _ = Ast_helper.Attr.as_tuple a in + str.Location.txt = name) + attrs let node_merlin_loc loc0 node = let attributes = node_attributes node in @@ -209,30 +234,31 @@ let node_merlin_loc loc0 node = | { attr_name; _ } -> attr_name.Location.loc | exception Not_found -> node_real_loc loc0 node in - let loc = match node with - | Expression {exp_extra; _} -> - List.fold_left ~f:(fun loc0 (_,loc,_) -> Location_aux.union loc0 loc) + let loc = + match node with + | Expression { exp_extra; _ } -> + List.fold_left + ~f:(fun loc0 (_, loc, _) -> Location_aux.union loc0 loc) ~init:loc exp_extra - | Pattern {pat_extra; _} -> - List.fold_left ~f:(fun loc0 (_,loc,_) -> Location_aux.union loc0 loc) + | Pattern { pat_extra; _ } -> + List.fold_left + ~f:(fun loc0 (_, loc, _) -> Location_aux.union loc0 loc) ~init:loc pat_extra | _ -> loc in loc -let app node env f acc = - f (node_update_env env node) - node acc +let app node env f acc = f (node_update_env env node) node acc type 'a f0 = Env.t -> node -> 'a -> 'a -type ('b,'a) f1 = 'b -> Env.t -> 'a f0 -> 'a -> 'a +type ('b, 'a) f1 = 'b -> Env.t -> 'a f0 -> 'a -> 'a let id_fold _env (_f : _ f0) acc = acc -let ( ** ) f1 f2 env (f : _ f0) acc = - f2 env f (f1 env f acc) +let ( ** ) f1 f2 env (f : _ f0) acc = f2 env f (f1 env f acc) -let rec list_fold (f' : _ f1) xs env f acc = match xs with +let rec list_fold (f' : _ f1) xs env f acc = + match xs with | x :: xs -> list_fold f' xs env f (f' x env f acc) | [] -> acc @@ -243,30 +269,30 @@ let array_fold (f' : _ f1) arr env f acc = done; !acc -let rec list_fold_with_next (f' : _ -> _ f1) xs env f acc = match xs with - | x :: (y :: _ as xs) -> list_fold_with_next f' xs env f (f' (Some y) x env f acc) - | [x] -> f' None x env f acc +let rec list_fold_with_next (f' : _ -> _ f1) xs env f acc = + match xs with + | x :: (y :: _ as xs) -> + list_fold_with_next f' xs env f (f' (Some y) x env f acc) + | [ x ] -> f' None x env f acc | [] -> acc -let option_fold f' o env (f : _ f0) acc = match o with +let option_fold f' o env (f : _ f0) acc = + match o with | None -> acc | Some x -> f' x env f acc let of_core_type ct = app (Core_type ct) -let of_exp_extra (exp,_,_) = match exp with - | Texp_constraint ct -> - of_core_type ct - | Texp_coerce (cto,ct) -> - of_core_type ct ** option_fold of_core_type cto - | Texp_poly cto -> - option_fold of_core_type cto - | Texp_newtype' _ - | Texp_newtype _ -> - id_fold +let of_exp_extra (exp, _, _) = + match exp with + | Texp_constraint ct -> of_core_type ct + | Texp_coerce (cto, ct) -> of_core_type ct ** option_fold of_core_type cto + | Texp_poly cto -> option_fold of_core_type cto + | Texp_newtype' _ | Texp_newtype _ -> id_fold let of_expression e = app (Expression e) ** list_fold of_exp_extra e.exp_extra -let of_pat_extra (pat,_,_) = match pat with +let of_pat_extra (pat, _, _) = + match pat with | Tpat_constraint ct -> of_core_type ct | Tpat_type _ | Tpat_unpack | Tpat_open _ -> id_fold @@ -278,7 +304,7 @@ let of_label_declaration ct = app (Label_declaration ct) let of_value_binding vb = app (Value_binding vb) let of_module_type mt = app (Module_type mt) let of_module_expr me = app (Module_expr me) -let of_typ_param (ct,_) = of_core_type ct +let of_typ_param (ct, _) = of_core_type ct let of_constructor_arguments = function | Cstr_tuple cts -> list_fold of_core_type cts | Cstr_record lbls -> list_fold of_label_declaration lbls @@ -286,99 +312,99 @@ let of_constructor_arguments = function let of_bop ({ bop_exp; _ } as bop) = app (Binding_op bop) ** of_expression bop_exp -let of_record_field obj loc lbl = - fun env (f : _ f0) acc -> - app (Record_field (obj,lbl,loc)) env f acc +let of_record_field obj loc lbl env (f : _ f0) acc = + app (Record_field (obj, lbl, loc)) env f acc let of_exp_record_field obj lid_loc lbl = of_record_field (`Expression obj) lid_loc lbl -let of_pat_record_field obj loc lbl = - of_record_field (`Pattern obj) loc lbl +let of_pat_record_field obj loc lbl = of_record_field (`Pattern obj) loc lbl let of_pattern_desc (type k) (desc : k pattern_desc) = match desc with - | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> id_fold - | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> + id_fold + | Tpat_alias (p, _, _, _) + | Tpat_variant (_, Some p, _) + | Tpat_lazy p | Tpat_exception p -> of_pattern p | Tpat_value p -> of_pattern (p :> value general_pattern) - | Tpat_tuple ps | Tpat_construct (_,_,ps,None) | Tpat_array ps -> + | Tpat_tuple ps | Tpat_construct (_, _, ps, None) | Tpat_array ps -> list_fold of_pattern ps - | Tpat_construct (_,_,ps,Some (_, ct)) -> + | Tpat_construct (_, _, ps, Some (_, ct)) -> list_fold of_pattern ps ** of_core_type ct - | Tpat_record (ls,_) -> - list_fold (fun (lid_loc,desc,p) -> - of_pat_record_field p lid_loc desc ** of_pattern p) ls - | Tpat_or (p1,p2,_) -> - of_pattern p1 ** of_pattern p2 - -let of_method_call obj meth loc = - fun env (f : _ f0) acc -> + | Tpat_record (ls, _) -> + list_fold + (fun (lid_loc, desc, p) -> + of_pat_record_field p lid_loc desc ** of_pattern p) + ls + | Tpat_or (p1, p2, _) -> of_pattern p1 ** of_pattern p2 + +let of_method_call obj meth loc env (f : _ f0) acc = let loc_start = obj.exp_loc.Location.loc_end in let loc_end = loc.Location.loc_end in - let loc = {loc with Location. loc_start; loc_end} in - app (Method_call (obj,meth,loc)) env f acc + let loc = { loc with Location.loc_start; loc_end } in + app (Method_call (obj, meth, loc)) env f acc let rec of_expression_desc loc = function | Texp_ident _ | Texp_constant _ | Texp_instvar _ - | Texp_variant (_,None) | Texp_new _ | Texp_hole -> id_fold - | Texp_let (_,vbs,e) -> - of_expression e ** list_fold of_value_binding vbs + | Texp_variant (_, None) + | Texp_new _ | Texp_hole -> id_fold + | Texp_let (_, vbs, e) -> of_expression e ** list_fold of_value_binding vbs | Texp_function (params, body) -> list_fold of_function_param params ** of_function_body body - | Texp_apply (e,ls) -> - of_expression e ** - list_fold (function - | (_,None) -> id_fold - | (_,Some e) -> of_expression e) - ls - | Texp_match (e,cs,_) -> - of_expression e ** - list_fold of_case cs - | Texp_try (e,cs) -> - of_expression e ** - list_fold of_case cs - | Texp_tuple es | Texp_construct (_,_,es) | Texp_array es -> - list_fold of_expression es - | Texp_variant (_,Some e) - | Texp_assert (e, _) | Texp_lazy e | Texp_setinstvar (_,_,_,e) -> + | Texp_apply (e, ls) -> of_expression e + ** list_fold + (function + | _, None -> id_fold + | _, Some e -> of_expression e) + ls + | Texp_match (e, cs, _) -> of_expression e ** list_fold of_case cs + | Texp_try (e, cs) -> of_expression e ** list_fold of_case cs + | Texp_tuple es | Texp_construct (_, _, es) | Texp_array es -> + list_fold of_expression es + | Texp_variant (_, Some e) + | Texp_assert (e, _) + | Texp_lazy e + | Texp_setinstvar (_, _, _, e) -> of_expression e | Texp_record { fields; extended_expression } -> - option_fold of_expression extended_expression ** + option_fold of_expression extended_expression + ** let fold_field = function - | (_,Typedtree.Kept _) -> id_fold - | (desc,Typedtree.Overridden (lid_loc,e)) -> + | _, Typedtree.Kept _ -> id_fold + | desc, Typedtree.Overridden (lid_loc, e) -> of_exp_record_field e lid_loc desc ** of_expression e in array_fold fold_field fields - | Texp_field (e,lid_loc,lbl) -> + | Texp_field (e, lid_loc, lbl) -> of_expression e ** of_exp_record_field e lid_loc lbl - | Texp_setfield (e1,lid_loc,lbl,e2) -> + | Texp_setfield (e1, lid_loc, lbl, e2) -> of_expression e1 ** of_expression e2 ** of_exp_record_field e1 lid_loc lbl - | Texp_ifthenelse (e1,e2,None) - | Texp_sequence (e1,e2) | Texp_while (e1,e2) -> - of_expression e1 ** of_expression e2 - | Texp_ifthenelse (e1,e2,Some e3) | Texp_for (_,_,e1,e2,_,e3) -> + | Texp_ifthenelse (e1, e2, None) | Texp_sequence (e1, e2) | Texp_while (e1, e2) + -> of_expression e1 ** of_expression e2 + | Texp_ifthenelse (e1, e2, Some e3) | Texp_for (_, _, e1, e2, _, e3) -> of_expression e1 ** of_expression e2 ** of_expression e3 - | Texp_send (e,meth) -> - of_expression e ** - of_method_call e meth loc (* TODO ulysse CHECK*) - | Texp_override (_,ls) -> - list_fold (fun (_,_,e) -> of_expression e) ls + | Texp_send (e, meth) -> + of_expression e ** of_method_call e meth loc (* TODO ulysse CHECK*) + | Texp_override (_, ls) -> list_fold (fun (_, _, e) -> of_expression e) ls | Texp_letmodule (mb_id, mb_name, mb_presence, mb_expr, e) -> let mb = - {mb_id;mb_name;mb_expr;mb_loc=Location.none;mb_attributes=[] - ; mb_presence; mb_uid=Shape.Uid.internal_not_actually_unique } + { mb_id; + mb_name; + mb_expr; + mb_loc = Location.none; + mb_attributes = []; + mb_presence; + mb_uid = Shape.Uid.internal_not_actually_unique + } in app (Module_binding mb) ** of_expression e - | Texp_letexception (ec,e) -> + | Texp_letexception (ec, e) -> app (Extension_constructor ec) ** of_expression e - | Texp_object (cs,_) -> - app (Class_structure cs) - | Texp_pack me -> - of_module_expr me - | Texp_unreachable | Texp_extension_constructor _ -> - id_fold + | Texp_object (cs, _) -> app (Class_structure cs) + | Texp_pack me -> of_module_expr me + | Texp_unreachable | Texp_extension_constructor _ -> id_fold | Texp_letop { let_; ands; body; _ } -> (* let+ ..pat1 and pat2 and ... are represented as pattern couples: [pat1; [pat2; ...]]. The following function flattens these couples. @@ -387,150 +413,108 @@ let rec of_expression_desc loc = function let rec flatten_patterns ~size acc pat = match pat.pat_desc with | Tpat_tuple [ tuple; pat ] when size > 0 -> - flatten_patterns ~size:(size - 1) (pat :: acc) tuple + flatten_patterns ~size:(size - 1) (pat :: acc) tuple | _ -> List.rev (pat :: acc) in let bindops = let_ :: ands in let patterns = flatten_patterns ~size:(List.length ands) [] body.c_lhs in let of_letop (pat, bindop) = of_bop bindop ** of_pattern pat in - list_fold of_letop (List.combine patterns bindops) ** - of_expression body.c_rhs - | Texp_open (od, e) -> - app (Module_expr od.open_expr) ** of_expression e + list_fold of_letop (List.combine patterns bindops) + ** of_expression body.c_rhs + | Texp_open (od, e) -> app (Module_expr od.open_expr) ** of_expression e and of_function_param fp = of_function_param_kind fp.fp_kind and of_function_param_kind = function | Tparam_pat pat -> of_pattern pat - | Tparam_optional_default (pat, exp) -> - of_pattern pat ** of_expression exp + | Tparam_optional_default (pat, exp) -> of_pattern pat ** of_expression exp and of_function_body = function | Tfunction_body exp -> of_expression exp | Tfunction_cases fc -> list_fold of_case fc.cases and of_class_expr_desc = function - | Tcl_ident (_,_,cts) -> - list_fold of_core_type cts - | Tcl_structure cs -> - app (Class_structure cs) - | Tcl_fun (_,p,es,ce,_) -> - list_fold (fun (_,e) -> of_expression e) es ** - of_pattern p ** - app (Class_expr ce) - | Tcl_apply (ce,es) -> - list_fold (function - | (_,None) -> id_fold - | (_,Some e) -> of_expression e) - es ** - app (Class_expr ce) - | Tcl_let (_,vbs,es,ce) -> - list_fold of_value_binding vbs ** - list_fold (fun (_,e) -> of_expression e) es ** - app (Class_expr ce) - | Tcl_constraint (ce,cto,_,_,_) -> - option_fold (fun ct -> app (Class_type ct)) cto ** - app (Class_expr ce) - | Tcl_open (_,ce) -> - app (Class_expr ce) + | Tcl_ident (_, _, cts) -> list_fold of_core_type cts + | Tcl_structure cs -> app (Class_structure cs) + | Tcl_fun (_, p, es, ce, _) -> + list_fold (fun (_, e) -> of_expression e) es + ** of_pattern p ** app (Class_expr ce) + | Tcl_apply (ce, es) -> + list_fold + (function + | _, None -> id_fold + | _, Some e -> of_expression e) + es + ** app (Class_expr ce) + | Tcl_let (_, vbs, es, ce) -> + list_fold of_value_binding vbs + ** list_fold (fun (_, e) -> of_expression e) es + ** app (Class_expr ce) + | Tcl_constraint (ce, cto, _, _, _) -> + option_fold (fun ct -> app (Class_type ct)) cto ** app (Class_expr ce) + | Tcl_open (_, ce) -> app (Class_expr ce) and of_class_field_desc = function - | Tcf_inherit (_,ce,_,_,_) -> - app (Class_expr ce) - | Tcf_val (_,_,_,cfk,_) | Tcf_method (_,_,cfk) -> + | Tcf_inherit (_, ce, _, _, _) -> app (Class_expr ce) + | Tcf_val (_, _, _, cfk, _) | Tcf_method (_, _, cfk) -> app (Class_field_kind cfk) - | Tcf_constraint (ct1,ct2) -> - of_core_type ct1 ** of_core_type ct2 - | Tcf_initializer e -> - of_expression e - | Tcf_attribute _ -> - id_fold (*TODO*) + | Tcf_constraint (ct1, ct2) -> of_core_type ct1 ** of_core_type ct2 + | Tcf_initializer e -> of_expression e + | Tcf_attribute _ -> id_fold (*TODO*) and of_module_expr_desc = function | Tmod_ident _ -> id_fold - | Tmod_structure str -> - app (Structure str) - | Tmod_functor (Unit,me) -> of_module_expr me - | Tmod_functor (Named (_, _, mt),me) -> + | Tmod_structure str -> app (Structure str) + | Tmod_functor (Unit, me) -> of_module_expr me + | Tmod_functor (Named (_, _, mt), me) -> of_module_type mt ** of_module_expr me - | Tmod_apply (me1,me2,_) -> - of_module_expr me1 ** - of_module_expr me2 - | Tmod_apply_unit (me1) -> - of_module_expr me1 - | Tmod_constraint (me,_,mtc,_) -> - of_module_expr me ** - app (Module_type_constraint mtc) - | Tmod_unpack (e,_) -> - of_expression e + | Tmod_apply (me1, me2, _) -> of_module_expr me1 ** of_module_expr me2 + | Tmod_apply_unit me1 -> of_module_expr me1 + | Tmod_constraint (me, _, mtc, _) -> + of_module_expr me ** app (Module_type_constraint mtc) + | Tmod_unpack (e, _) -> of_expression e | Tmod_hole -> id_fold and of_structure_item_desc = function - | Tstr_eval (e,_) -> - of_expression e - | Tstr_value (_,vbs) -> - list_fold of_value_binding vbs - | Tstr_primitive vd -> - app (Value_description vd) - | Tstr_type (_,tds) -> - list_fold (fun td -> app (Type_declaration td)) tds - | Tstr_typext text -> - app (Type_extension text) - | Tstr_exception texn -> - app (Extension_constructor texn.tyexn_constructor) - | Tstr_module mb -> - app (Module_binding mb) - | Tstr_recmodule mbs -> - list_fold (fun x -> app (Module_binding x)) mbs - | Tstr_modtype mtd -> - app (Module_type_declaration mtd) - | Tstr_class cds -> - list_fold (fun (cd,_) -> app (Class_declaration cd)) cds + | Tstr_eval (e, _) -> of_expression e + | Tstr_value (_, vbs) -> list_fold of_value_binding vbs + | Tstr_primitive vd -> app (Value_description vd) + | Tstr_type (_, tds) -> list_fold (fun td -> app (Type_declaration td)) tds + | Tstr_typext text -> app (Type_extension text) + | Tstr_exception texn -> app (Extension_constructor texn.tyexn_constructor) + | Tstr_module mb -> app (Module_binding mb) + | Tstr_recmodule mbs -> list_fold (fun x -> app (Module_binding x)) mbs + | Tstr_modtype mtd -> app (Module_type_declaration mtd) + | Tstr_class cds -> list_fold (fun (cd, _) -> app (Class_declaration cd)) cds | Tstr_class_type ctds -> - list_fold (fun (_,_,ctd) -> app (Class_type_declaration ctd)) ctds - | Tstr_include i -> - app (Include_declaration i) - | Tstr_open d -> - app (Open_declaration d) - | Tstr_attribute _ -> - id_fold + list_fold (fun (_, _, ctd) -> app (Class_type_declaration ctd)) ctds + | Tstr_include i -> app (Include_declaration i) + | Tstr_open d -> app (Open_declaration d) + | Tstr_attribute _ -> id_fold and of_module_type_desc = function | Tmty_ident _ | Tmty_alias _ -> id_fold - | Tmty_signature sg -> - app (Signature sg) - | Tmty_functor (Named (_,_,mt1),mt2) -> + | Tmty_signature sg -> app (Signature sg) + | Tmty_functor (Named (_, _, mt1), mt2) -> of_module_type mt1 ** of_module_type mt2 - | Tmty_functor (Unit,mt) -> of_module_type mt - | Tmty_with (mt,wcs) -> - list_fold (fun (_,_,wc) -> app (With_constraint wc)) wcs ** - of_module_type mt - | Tmty_typeof me -> - of_module_expr me + | Tmty_functor (Unit, mt) -> of_module_type mt + | Tmty_with (mt, wcs) -> + list_fold (fun (_, _, wc) -> app (With_constraint wc)) wcs + ** of_module_type mt + | Tmty_typeof me -> of_module_expr me and of_signature_item_desc = function - | Tsig_attribute _ -> - id_fold - | Tsig_open d -> - app (Open_description d) - | Tsig_value vd -> - app (Value_description vd) - | Tsig_type (_,tds) -> - list_fold (fun td -> app (Type_declaration td)) tds - | Tsig_typext text -> - app (Type_extension text) - | Tsig_exception texn -> - app (Extension_constructor texn.tyexn_constructor) - | Tsig_module md -> - app (Module_declaration md) - | Tsig_recmodule mds -> - list_fold (fun md -> app (Module_declaration md)) mds - | Tsig_modtype mtd -> - app (Module_type_declaration mtd) - | Tsig_include i -> - app (Include_description i) - | Tsig_class cds -> - list_fold (fun cd -> app (Class_description cd)) cds + | Tsig_attribute _ -> id_fold + | Tsig_open d -> app (Open_description d) + | Tsig_value vd -> app (Value_description vd) + | Tsig_type (_, tds) -> list_fold (fun td -> app (Type_declaration td)) tds + | Tsig_typext text -> app (Type_extension text) + | Tsig_exception texn -> app (Extension_constructor texn.tyexn_constructor) + | Tsig_module md -> app (Module_declaration md) + | Tsig_recmodule mds -> list_fold (fun md -> app (Module_declaration md)) mds + | Tsig_modtype mtd -> app (Module_type_declaration mtd) + | Tsig_include i -> app (Include_description i) + | Tsig_class cds -> list_fold (fun cd -> app (Class_description cd)) cds | Tsig_class_type ctds -> list_fold (fun ctd -> app (Class_type_declaration ctd)) ctds | Tsig_typesubst tds -> @@ -545,271 +529,224 @@ and of_signature_item_desc = function and of_core_type_desc = function | Ttyp_any | Ttyp_var _ -> id_fold - | Ttyp_open (_,_,ct) -> of_core_type ct - | Ttyp_arrow (_,ct1,ct2) -> - of_core_type ct1 ** of_core_type ct2 - | Ttyp_tuple cts | Ttyp_constr (_,_,cts) | Ttyp_class (_,_,cts) -> + | Ttyp_open (_, _, ct) -> of_core_type ct + | Ttyp_arrow (_, ct1, ct2) -> of_core_type ct1 ** of_core_type ct2 + | Ttyp_tuple cts | Ttyp_constr (_, _, cts) | Ttyp_class (_, _, cts) -> list_fold of_core_type cts - | Ttyp_object (cts,_) -> - list_fold (fun of_ -> - 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 - | Ttyp_package pt -> - app (Package_type pt) + | Ttyp_object (cts, _) -> + list_fold + (fun of_ -> + 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 + | Ttyp_package pt -> app (Package_type pt) and of_class_type_desc = function - | Tcty_constr (_,_,cts) -> - list_fold of_core_type cts - | Tcty_signature cs -> - app (Class_signature cs) - | Tcty_arrow (_,ct,clt) -> - of_core_type ct ** app (Class_type clt) - | Tcty_open (_,ct) -> - app (Class_type ct) + | Tcty_constr (_, _, cts) -> list_fold of_core_type cts + | Tcty_signature cs -> app (Class_signature cs) + | Tcty_arrow (_, ct, clt) -> of_core_type ct ** app (Class_type clt) + | Tcty_open (_, ct) -> app (Class_type ct) and of_class_type_field_desc = function - | Tctf_inherit ct -> - app (Class_type ct) - | Tctf_val (_,_,_,ct) | Tctf_method (_,_,_,ct) -> - of_core_type ct - | Tctf_constraint (ct1,ct2) -> - of_core_type ct1 ** of_core_type ct2 - | Tctf_attribute _ -> - id_fold + | Tctf_inherit ct -> app (Class_type ct) + | Tctf_val (_, _, _, ct) | Tctf_method (_, _, _, ct) -> of_core_type ct + | Tctf_constraint (ct1, ct2) -> of_core_type ct1 ** of_core_type ct2 + | Tctf_attribute _ -> id_fold let of_node = function | Dummy -> id_fold - | Pattern { pat_desc; pat_extra=_ } -> - of_pattern_desc pat_desc - | Expression { exp_desc; exp_extra=_; exp_loc } -> + | Pattern { pat_desc; pat_extra = _ } -> of_pattern_desc pat_desc + | Expression { exp_desc; exp_extra = _; exp_loc } -> of_expression_desc exp_loc exp_desc | Case { c_lhs; c_guard; c_rhs } -> - of_pattern c_lhs ** of_expression c_rhs ** - option_fold of_expression c_guard - | Class_expr { cl_desc } -> - of_class_expr_desc cl_desc + of_pattern c_lhs ** of_expression c_rhs ** option_fold of_expression c_guard + | Class_expr { cl_desc } -> of_class_expr_desc cl_desc | Class_structure { cstr_self; cstr_fields } -> - of_pattern cstr_self ** - list_fold (fun f -> app (Class_field f)) cstr_fields - | Class_field { cf_desc } -> - of_class_field_desc cf_desc - | Class_field_kind (Tcfk_virtual ct) -> - of_core_type ct - | Class_field_kind (Tcfk_concrete (_,e)) -> - of_expression e - | Module_expr { mod_desc } -> - of_module_expr_desc mod_desc - | Module_type_constraint Tmodtype_implicit -> - id_fold - | Module_type_constraint (Tmodtype_explicit mt) -> - of_module_type mt + of_pattern cstr_self ** list_fold (fun f -> app (Class_field f)) cstr_fields + | Class_field { cf_desc } -> of_class_field_desc cf_desc + | Class_field_kind (Tcfk_virtual ct) -> of_core_type ct + | Class_field_kind (Tcfk_concrete (_, e)) -> of_expression e + | Module_expr { mod_desc } -> of_module_expr_desc mod_desc + | Module_type_constraint Tmodtype_implicit -> id_fold + | Module_type_constraint (Tmodtype_explicit mt) -> of_module_type mt | Structure { str_items; str_final_env } -> - list_fold_with_next (fun next item -> + 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))) str_items - | Structure_item ({ str_desc }, _) -> - of_structure_item_desc str_desc + | Structure_item ({ str_desc }, _) -> of_structure_item_desc str_desc | Module_binding mb -> - app (Module_expr mb.mb_expr) ** - app (Module_binding_name mb) + app (Module_expr mb.mb_expr) ** app (Module_binding_name mb) | Value_binding { vb_pat; vb_expr } -> - of_pattern vb_pat ** - of_expression vb_expr - | Module_type { mty_desc } -> - of_module_type_desc mty_desc + of_pattern vb_pat ** of_expression vb_expr + | Module_type { mty_desc } -> of_module_type_desc mty_desc | Signature { sig_items; sig_final_env } -> - list_fold_with_next (fun next item -> + 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))) sig_items - | Signature_item ({ sig_desc }, _) -> - of_signature_item_desc sig_desc + | Signature_item ({ sig_desc }, _) -> of_signature_item_desc sig_desc | Module_declaration md -> - of_module_type md.md_type ** - app (Module_declaration_name md) + of_module_type md.md_type ** app (Module_declaration_name md) | Module_type_declaration mtd -> - option_fold of_module_type mtd.mtd_type ** - app (Module_type_declaration_name mtd) + option_fold of_module_type mtd.mtd_type + ** app (Module_type_declaration_name mtd) | With_constraint (Twith_type td | Twith_typesubst td) -> app (Type_declaration td) - | With_constraint (Twith_module _ | Twith_modsubst _) -> - id_fold + | With_constraint (Twith_module _ | Twith_modsubst _) -> id_fold | With_constraint (Twith_modtype mt | Twith_modtypesubst mt) -> of_module_type mt - | Core_type { ctyp_desc } -> - of_core_type_desc ctyp_desc + | Core_type { ctyp_desc } -> of_core_type_desc ctyp_desc | Package_type { pack_fields } -> - list_fold (fun (_,ct) -> of_core_type ct) pack_fields + list_fold (fun (_, ct) -> of_core_type ct) pack_fields | Row_field rf -> begin - 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 + 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 - option_fold of_core_type typ_manifest ** - list_fold of_typ_param typ_params ** - app (Type_kind typ_kind) ** - list_fold of_typ_cstrs typ_cstrs - | Type_kind (Ttype_abstract | Ttype_open) -> - id_fold + let of_typ_cstrs (ct1, ct2, _) = of_core_type ct1 ** of_core_type ct2 in + option_fold of_core_type typ_manifest + ** list_fold of_typ_param typ_params + ** app (Type_kind typ_kind) + ** list_fold of_typ_cstrs typ_cstrs + | Type_kind (Ttype_abstract | Ttype_open) -> id_fold | Type_kind (Ttype_variant cds) -> list_fold (fun cd -> app (Constructor_declaration cd)) cds - | Type_kind (Ttype_record lds) -> - list_fold of_label_declaration lds + | Type_kind (Ttype_record lds) -> list_fold of_label_declaration lds | Type_extension { tyext_params; tyext_constructors } -> - list_fold of_typ_param tyext_params ** - list_fold (fun ec -> app (Extension_constructor ec)) tyext_constructors - | Extension_constructor { ext_kind = Text_decl (_, carg,cto) } -> - option_fold of_core_type cto ** - of_constructor_arguments carg - | Extension_constructor { ext_kind = Text_rebind _ } -> - id_fold - | Label_declaration { ld_type } -> - of_core_type ld_type + list_fold of_typ_param tyext_params + ** list_fold (fun ec -> app (Extension_constructor ec)) tyext_constructors + | Extension_constructor { ext_kind = Text_decl (_, carg, cto) } -> + option_fold of_core_type cto ** of_constructor_arguments carg + | Extension_constructor { ext_kind = Text_rebind _ } -> id_fold + | Label_declaration { ld_type } -> of_core_type ld_type | Constructor_declaration { cd_args; cd_res } -> - option_fold of_core_type cd_res ** - of_constructor_arguments cd_args - | Class_type { cltyp_desc } -> - of_class_type_desc cltyp_desc + option_fold of_core_type cd_res ** of_constructor_arguments cd_args + | Class_type { cltyp_desc } -> of_class_type_desc cltyp_desc | Class_signature { csig_self; csig_fields } -> - of_core_type csig_self ** - list_fold (fun x -> app (Class_type_field x)) csig_fields - | Class_type_field { ctf_desc } -> - of_class_type_field_desc ctf_desc + of_core_type csig_self + ** list_fold (fun x -> app (Class_type_field x)) csig_fields + | Class_type_field { ctf_desc } -> of_class_type_field_desc ctf_desc | Class_declaration { ci_params; ci_expr } -> - app (Class_expr ci_expr) ** - list_fold of_typ_param ci_params + app (Class_expr ci_expr) ** list_fold of_typ_param ci_params | Class_description { ci_params; ci_expr } -> - app (Class_type ci_expr) ** - list_fold of_typ_param ci_params + app (Class_type ci_expr) ** list_fold of_typ_param ci_params | Class_type_declaration { ci_params; ci_expr } -> - app (Class_type ci_expr) ** - list_fold of_typ_param ci_params + app (Class_type ci_expr) ** list_fold of_typ_param ci_params | Method_call _ -> id_fold | Record_field _ -> id_fold | Module_binding_name _ -> id_fold | Module_declaration_name _ -> id_fold | Module_type_declaration_name _ -> id_fold | Open_description _ -> id_fold - | Open_declaration od -> - app (Module_expr od.open_expr) - | Include_declaration i -> - of_module_expr i.incl_mod - | Include_description i -> - of_module_type i.incl_mod - | Binding_op { bop_exp=_ } -> - id_fold + | Open_declaration od -> app (Module_expr od.open_expr) + | Include_declaration i -> of_module_expr i.incl_mod + | Include_description i -> of_module_type i.incl_mod + | Binding_op { bop_exp = _ } -> id_fold -let fold_node f env node acc = - of_node node env f acc +let fold_node f env node acc = of_node node env f acc (** Accessors for information specific to a node *) let string_of_node = function | Dummy -> "dummy" - | Pattern p -> + | Pattern p -> let fmt, printer = Format.to_string () in - Printtyped.pattern 0 fmt p ; + Printtyped.pattern 0 fmt p; printer () - | Expression _ -> "expression" - | Case _ -> "case" - | Class_expr _ -> "class_expr" - | Class_structure _ -> "class_structure" - | Class_field _ -> "class_field" - | Class_field_kind _ -> "class_field_kind" - | Module_expr _ -> "module_expr" - | Module_type_constraint _ -> "module_type_constraint" - | Structure _ -> "structure" - | Structure_item _ -> "structure_item" - | Module_binding _ -> "module_binding" - | Value_binding _ -> "value_binding" - | Module_type _ -> "module_type" - | Signature _ -> "signature" - | Signature_item _ -> "signature_item" - | Module_declaration _ -> "module_declaration" + | Expression _ -> "expression" + | Case _ -> "case" + | Class_expr _ -> "class_expr" + | Class_structure _ -> "class_structure" + | Class_field _ -> "class_field" + | Class_field_kind _ -> "class_field_kind" + | Module_expr _ -> "module_expr" + | Module_type_constraint _ -> "module_type_constraint" + | Structure _ -> "structure" + | Structure_item _ -> "structure_item" + | Module_binding _ -> "module_binding" + | Value_binding _ -> "value_binding" + | Module_type _ -> "module_type" + | Signature _ -> "signature" + | Signature_item _ -> "signature_item" + | Module_declaration _ -> "module_declaration" | Module_type_declaration _ -> "module_type_declaration" - | With_constraint _ -> "with_constraint" - | Core_type _ -> "core_type" - | Package_type _ -> "package_type" - | Row_field _ -> "row_field" - | Value_description _ -> "value_description" - | Type_declaration _ -> "type_declaration" - | Type_kind _ -> "type_kind" - | Type_extension _ -> "type_extension" - | Extension_constructor _ -> "extension_constructor" - | Label_declaration _ -> "label_declaration" + | With_constraint _ -> "with_constraint" + | Core_type _ -> "core_type" + | Package_type _ -> "package_type" + | Row_field _ -> "row_field" + | Value_description _ -> "value_description" + | Type_declaration _ -> "type_declaration" + | Type_kind _ -> "type_kind" + | Type_extension _ -> "type_extension" + | Extension_constructor _ -> "extension_constructor" + | Label_declaration _ -> "label_declaration" | Constructor_declaration _ -> "constructor_declaration" - | Class_type _ -> "class_type" - | Class_signature _ -> "class_signature" - | Class_type_field _ -> "class_type_field" - | Class_declaration _ -> "class_declaration" - | Class_description _ -> "class_description" - | Class_type_declaration _ -> "class_type_declaration" - | Binding_op _ -> "binding_op" - | Method_call _ -> "method_call" - | Record_field _ -> "record_field" - | Module_binding_name _ -> "module_binding_name" + | Class_type _ -> "class_type" + | Class_signature _ -> "class_signature" + | Class_type_field _ -> "class_type_field" + | Class_declaration _ -> "class_declaration" + | Class_description _ -> "class_description" + | Class_type_declaration _ -> "class_type_declaration" + | Binding_op _ -> "binding_op" + | Method_call _ -> "method_call" + | Record_field _ -> "record_field" + | Module_binding_name _ -> "module_binding_name" | Module_declaration_name _ -> "module_declaration_name" | Module_type_declaration_name _ -> "module_type_declaration_name" - | Open_description _ -> "open_description" - | Open_declaration _ -> "open_declaration" - | Include_description _ -> "include_description" - | Include_declaration _ -> "include_declaration" + | Open_description _ -> "open_description" + | Open_declaration _ -> "open_declaration" + | Include_description _ -> "include_description" + | Include_declaration _ -> "include_declaration" let mkloc = Location.mkloc -let reloc txt loc = {loc with Location. txt} +let reloc txt loc = { loc with Location.txt } let mk_lident x = Longident.Lident x let type_constructor_path typ = match Types.get_desc typ with - | Types.Tconstr (p,_,_) -> p + | Types.Tconstr (p, _, _) -> p | _ -> raise Not_found (* Build a fake path for value constructors and labels *) -let fake_path {Location.loc ; txt = lid} typ name = +let fake_path { Location.loc; txt = lid } typ name = match type_constructor_path typ with - | Path.Pdot (p, _) -> - [mkloc (Path.Pdot (p, name)) loc, Some lid] + | Path.Pdot (p, _) -> [ (mkloc (Path.Pdot (p, name)) loc, Some lid) ] | Path.Pident _ -> - [mkloc (Path.Pident (Ident.create_persistent name)) loc, Some lid] - | _ | exception Not_found -> [] + [ (mkloc (Path.Pident (Ident.create_persistent name)) loc, Some lid) ] + | _ | (exception Not_found) -> [] -let pattern_paths (type k) { Typedtree. pat_desc; pat_extra; _ } = +let pattern_paths (type k) { Typedtree.pat_desc; pat_extra; _ } = let init = match (pat_desc : k pattern_desc) with - | Tpat_construct (lid_loc,{Types. cstr_name; cstr_res; _},_,_) -> + | Tpat_construct (lid_loc, { Types.cstr_name; cstr_res; _ }, _, _) -> fake_path lid_loc cstr_res cstr_name - | Tpat_var (id, {Location. loc; txt}, _uid) -> - [mkloc (Path.Pident id) loc, Some (Longident.Lident txt)] - | Tpat_alias (_,id,loc, _uid) -> - [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)] + | Tpat_var (id, { Location.loc; txt }, _uid) -> + [ (mkloc (Path.Pident id) loc, Some (Longident.Lident txt)) ] + | Tpat_alias (_, id, loc, _uid) -> + [ (reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)) ] | _ -> [] in - List.fold_left ~init pat_extra - ~f:(fun acc (extra,_,_) -> + List.fold_left ~init pat_extra ~f:(fun acc (extra, _, _) -> match extra with - | Tpat_open (path,loc,_) | Tpat_type (path,loc) -> + | Tpat_open (path, loc, _) | Tpat_type (path, loc) -> (reloc path loc, Some loc.txt) :: acc | _ -> acc) -let module_expr_paths { Typedtree. mod_desc } = +let module_expr_paths { Typedtree.mod_desc } = match mod_desc with - | Tmod_ident (path, loc) -> [reloc path loc, Some loc.txt] + | Tmod_ident (path, loc) -> [ (reloc path loc, Some loc.txt) ] | Tmod_functor (Named (Some id, loc, _), _) -> - [reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt] + [ (reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt) ] | _ -> [] let bindop_path { bop_op_name; bop_op_path } = @@ -817,130 +754,134 @@ let bindop_path { bop_op_name; bop_op_path } = let path = bop_op_path in (reloc path loc, Some (Longident.Lident loc.txt)) -let expression_paths { Typedtree. exp_desc; exp_extra; _ } = +let expression_paths { Typedtree.exp_desc; exp_extra; _ } = let init = match exp_desc with - | Texp_ident (path,loc,_) -> [reloc path loc, Some loc.txt] - | Texp_letop {let_; ands} -> + | Texp_ident (path, loc, _) -> [ (reloc path loc, Some loc.txt) ] + | Texp_letop { let_; ands } -> bindop_path let_ :: List.map ~f:bindop_path ands - | Texp_new (path,loc,_) -> [reloc path loc, Some loc.txt] - | Texp_instvar (_,path,loc) -> [reloc path loc, Some (Lident loc.txt)] - | Texp_setinstvar (_,path,loc,_) -> [reloc path loc, Some (Lident loc.txt)] - | Texp_override (_,ps) -> - List.map ~f:(fun (id,loc,_) -> - 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] - | Texp_for (id,{Parsetree.ppat_loc = loc; ppat_desc},_,_,_,_) -> + | Texp_new (path, loc, _) -> [ (reloc path loc, Some loc.txt) ] + | Texp_instvar (_, path, loc) -> [ (reloc path loc, Some (Lident loc.txt)) ] + | Texp_setinstvar (_, path, loc, _) -> + [ (reloc path loc, Some (Lident loc.txt)) ] + | Texp_override (_, ps) -> + List.map + ~f:(fun (id, loc, _) -> + (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) ] + | Texp_for (id, { Parsetree.ppat_loc = loc; ppat_desc }, _, _, _, _) -> let lid = match ppat_desc with | Ppat_any -> None - | Ppat_var {txt} -> Some (Longident.Lident txt) + | Ppat_var { txt } -> Some (Longident.Lident txt) | _ -> assert false in - [mkloc (Path.Pident id) loc, lid] - | Texp_construct (lid_loc, {Types. cstr_name; cstr_res; _}, _) -> + [ (mkloc (Path.Pident id) loc, lid) ] + | Texp_construct (lid_loc, { Types.cstr_name; cstr_res; _ }, _) -> fake_path lid_loc cstr_res cstr_name - | Texp_open (od,_) -> module_expr_paths od.open_expr + | Texp_open (od, _) -> module_expr_paths od.open_expr | _ -> [] in - List.fold_left ~init exp_extra - ~f:(fun acc (extra, _, _) -> + List.fold_left ~init exp_extra ~f:(fun acc (extra, _, _) -> match extra with | Texp_newtype' (id, label_loc, _) -> let path = Path.Pident id in - let lid = Longident.Lident (label_loc.txt) in + let lid = Longident.Lident label_loc.txt in (mkloc path label_loc.loc, Some lid) :: acc | _ -> acc) -let core_type_paths { Typedtree. ctyp_desc } = +let core_type_paths { Typedtree.ctyp_desc } = match ctyp_desc with - | Ttyp_constr (path,loc,_) -> [reloc path loc, Some loc.txt] - | Ttyp_class (path,loc,_) -> [reloc path loc, Some loc.txt] + | Ttyp_constr (path, loc, _) -> [ (reloc path loc, Some loc.txt) ] + | Ttyp_class (path, loc, _) -> [ (reloc path loc, Some loc.txt) ] | _ -> [] -let class_expr_paths { Typedtree. cl_desc } = +let class_expr_paths { Typedtree.cl_desc } = match cl_desc with - | Tcl_ident (path, loc, _) -> [reloc path loc, Some loc.txt] + | Tcl_ident (path, loc, _) -> [ (reloc path loc, Some loc.txt) ] | _ -> [] -let class_field_paths { Typedtree. cf_desc } = +let class_field_paths { Typedtree.cf_desc } = match cf_desc with - | Tcf_val (loc,_,id,_,_) -> - [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)] + | Tcf_val (loc, _, id, _, _) -> + [ (reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)) ] | _ -> [] -let structure_item_paths { Typedtree. str_desc } = +let structure_item_paths { Typedtree.str_desc } = match str_desc with | Tstr_class_type cls -> - List.map ~f:(fun (id,loc,_) -> - reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt) - ) cls + List.map + ~f:(fun (id, loc, _) -> + (reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt))) + cls | Tstr_open od -> module_expr_paths od.open_expr | _ -> [] -let module_type_paths { Typedtree. mty_desc } = +let module_type_paths { Typedtree.mty_desc } = match mty_desc with | Tmty_ident (path, loc) | Tmty_alias (path, loc) -> - [reloc path loc, Some loc.txt] - | Tmty_functor (Named (Some id,loc,_),_) -> - [reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt] - | Tmty_with (_,ls) -> - List.map ~f:(fun (p,l,_) -> reloc p l, Some l.txt) ls + [ (reloc path loc, Some loc.txt) ] + | Tmty_functor (Named (Some id, loc, _), _) -> + [ (reloc (Path.Pident id) loc, Option.map ~f:mk_lident loc.txt) ] + | Tmty_with (_, ls) -> + List.map ~f:(fun (p, l, _) -> (reloc p l, Some l.txt)) ls | _ -> [] -let signature_item_paths { Typedtree. sig_desc } = +let signature_item_paths { Typedtree.sig_desc } = match sig_desc with - | Tsig_open { Typedtree. open_expr = (open_path, open_txt); _ } -> - [reloc open_path open_txt, Some open_txt.txt] + | Tsig_open { Typedtree.open_expr = open_path, open_txt; _ } -> + [ (reloc open_path open_txt, Some open_txt.txt) ] | _ -> [] let with_constraint_paths = function - | Twith_module (path,loc) | Twith_modsubst (path,loc) -> - [reloc path loc, Some loc.txt] + | Twith_module (path, loc) | Twith_modsubst (path, loc) -> + [ (reloc path loc, Some loc.txt) ] | _ -> [] -let ci_paths {Typedtree. ci_id_name; ci_id_class } = - [reloc (Path.Pident ci_id_class) ci_id_name, - Some (Longident.Lident ci_id_name.txt)] +let ci_paths { Typedtree.ci_id_name; ci_id_class } = + [ ( reloc (Path.Pident ci_id_class) ci_id_name, + Some (Longident.Lident ci_id_name.txt) ) + ] let node_paths_full = - let open Typedtree in function + let open Typedtree in + function | Pattern p -> pattern_paths p | Expression e -> expression_paths e | Class_expr e -> class_expr_paths e | Class_field f -> class_field_paths f | Module_expr me -> module_expr_paths me - | Structure_item (i,_) -> structure_item_paths i + | Structure_item (i, _) -> structure_item_paths i | Module_binding_name { mb_id = Some mb_id; mb_name } -> - [reloc (Path.Pident mb_id) mb_name, Option.map ~f:mk_lident mb_name.txt] + [ (reloc (Path.Pident mb_id) mb_name, Option.map ~f:mk_lident mb_name.txt) ] | Module_type mt -> module_type_paths mt - | Signature_item (i,_) -> signature_item_paths i + | Signature_item (i, _) -> signature_item_paths i | Module_declaration_name { md_id = Some md_id; md_name } -> - [reloc (Path.Pident md_id) md_name, Option.map ~f:mk_lident md_name.txt] + [ (reloc (Path.Pident md_id) md_name, Option.map ~f:mk_lident md_name.txt) ] | Module_type_declaration_name { mtd_id; mtd_name } -> - [reloc (Path.Pident mtd_id) mtd_name, Some (Lident mtd_name.txt) ] + [ (reloc (Path.Pident mtd_id) mtd_name, Some (Lident mtd_name.txt)) ] | With_constraint c -> with_constraint_paths c | Core_type ct -> core_type_paths ct | Package_type { pack_path; pack_txt } -> - [reloc pack_path pack_txt, Some pack_txt.txt] + [ (reloc pack_path pack_txt, Some pack_txt.txt) ] | Value_description { val_id; val_name } -> - [reloc (Path.Pident val_id) val_name, Some (Lident val_name.txt)] + [ (reloc (Path.Pident val_id) val_name, Some (Lident val_name.txt)) ] | Type_declaration { typ_id; typ_name } -> - [reloc (Path.Pident typ_id) typ_name, Some (Lident typ_name.txt)] + [ (reloc (Path.Pident typ_id) typ_name, Some (Lident typ_name.txt)) ] | Type_extension { tyext_path; tyext_txt } -> - [reloc tyext_path tyext_txt, Some tyext_txt.txt] + [ (reloc tyext_path tyext_txt, Some tyext_txt.txt) ] | Extension_constructor { ext_id; ext_name } -> - [reloc (Path.Pident ext_id) ext_name, Some (Lident ext_name.txt)] + [ (reloc (Path.Pident ext_id) ext_name, Some (Lident ext_name.txt)) ] | Label_declaration { ld_id; ld_name } -> - [reloc (Path.Pident ld_id) ld_name, Some (Lident ld_name.txt)] + [ (reloc (Path.Pident ld_id) ld_name, Some (Lident ld_name.txt)) ] | Constructor_declaration { cd_id; cd_name } -> - [reloc (Path.Pident cd_id) cd_name, Some (Lident cd_name.txt)] + [ (reloc (Path.Pident cd_id) cd_name, Some (Lident cd_name.txt)) ] | Class_declaration ci -> ci_paths ci | Class_description ci -> ci_paths ci | Class_type_declaration ci -> ci_paths ci - | Record_field (_,{Types.lbl_res; lbl_name; _},lid_loc) -> + | Record_field (_, { Types.lbl_res; lbl_name; _ }, lid_loc) -> fake_path lid_loc lbl_res lbl_name | _ -> [] @@ -948,58 +889,40 @@ 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) - ) + | p, Some lid -> Some (p, lid)) let node_is_constructor = function | Constructor_declaration decl -> - Some {decl.cd_name with Location.txt = `Declaration decl} - | Expression {exp_desc = Texp_construct (loc, desc, _)} -> - Some {loc with Location.txt = `Description desc} - | Pattern {pat_desc = Tpat_construct (loc, desc, _, _)} -> - Some {loc with Location.txt = `Description desc} + Some { decl.cd_name with Location.txt = `Declaration decl } + | Expression { exp_desc = Texp_construct (loc, desc, _) } -> + Some { loc with Location.txt = `Description desc } + | Pattern { pat_desc = Tpat_construct (loc, desc, _, _) } -> + Some { loc with Location.txt = `Description desc } | Extension_constructor ext_cons -> - Some { Location.loc = ext_cons.ext_loc; - txt = `Extension_constructor ext_cons} + Some + { Location.loc = ext_cons.ext_loc; txt = `Extension_constructor ext_cons } | _ -> None let node_of_binary_part env part = let open Cmt_format in match part with - | Partial_structure x -> - Structure x - | Partial_structure_item x -> - Structure_item (x, env) - | Partial_expression x -> - Expression x - | Partial_pattern (_, x) -> - Pattern x - | Partial_class_expr x -> - Class_expr x - | Partial_signature x -> - Signature x - | Partial_signature_item x -> - Signature_item (x, env) - | Partial_module_type x -> - Module_type x + | Partial_structure x -> Structure x + | Partial_structure_item x -> Structure_item (x, env) + | Partial_expression x -> Expression x + | Partial_pattern (_, x) -> Pattern x + | Partial_class_expr x -> Class_expr x + | Partial_signature x -> Signature x + | Partial_signature_item x -> Signature_item (x, env) + | Partial_module_type x -> Module_type x let all_holes (env, node) = let rec aux acc (env, node) = - let f env node acc = match node with - | Expression { - exp_desc = Texp_hole; - exp_loc; - exp_type; - exp_env; - _ - } -> (exp_loc, exp_env, `Exp exp_type) :: acc - | Module_expr { - mod_desc = Tmod_hole; - mod_loc; - mod_type; - mod_env; - _ - } -> (mod_loc, mod_env, `Mod mod_type) :: acc + let f env node acc = + match node with + | Expression { exp_desc = Texp_hole; exp_loc; exp_type; exp_env; _ } -> + (exp_loc, exp_env, `Exp exp_type) :: acc + | Module_expr { mod_desc = Tmod_hole; mod_loc; mod_type; mod_env; _ } -> + (mod_loc, mod_env, `Mod mod_type) :: acc | _ -> aux acc (env, node) in fold_node f env node acc diff --git a/src/ocaml/merlin_specific/browse_raw.mli b/src/ocaml/merlin_specific/browse_raw.mli index 06d2b1cec..0495a0018 100644 --- a/src/ocaml/merlin_specific/browse_raw.mli +++ b/src/ocaml/merlin_specific/browse_raw.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2014 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2014 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) (** [Browse_node] offers a uniform interface to traverse constructions from * [TypedTree]. @@ -48,56 +48,54 @@ open Typedtree type node = | Dummy - | Pattern : _ general_pattern -> node - | Expression of expression - | Case : _ case -> node - | Class_expr of class_expr - | Class_structure of class_structure - | Class_field of class_field - | Class_field_kind of class_field_kind - | Module_expr of module_expr - | Module_type_constraint of module_type_constraint - | Structure of structure - | Signature of signature + | Pattern : _ general_pattern -> node + | Expression of expression + | Case : _ case -> node + | Class_expr of class_expr + | Class_structure of class_structure + | Class_field of class_field + | Class_field_kind of class_field_kind + | Module_expr of module_expr + | Module_type_constraint of module_type_constraint + | Structure of structure + | Signature of signature | (* Items come with their final environment *) - Structure_item of structure_item * Env.t - | Signature_item of signature_item * Env.t - | Module_binding of module_binding - | Value_binding of value_binding - | Module_type of module_type - | Module_declaration of module_declaration - | Module_type_declaration of module_type_declaration - | With_constraint of with_constraint - | Core_type of core_type - | Package_type of package_type - | Row_field of row_field - | Value_description of value_description - | Type_declaration of type_declaration - | Type_kind of type_kind - | Type_extension of type_extension - | Extension_constructor of extension_constructor - | Label_declaration of label_declaration - | Constructor_declaration of constructor_declaration - | Class_type of class_type - | Class_signature of class_signature - | Class_type_field of class_type_field - | Class_declaration of class_declaration - | Class_description of class_description - | Class_type_declaration of class_type_declaration - | Binding_op of binding_op - - | Include_description of include_description - | Include_declaration of include_declaration - | Open_description of open_description - | Open_declaration of open_declaration - - | Method_call of expression * meth * Location.t - | Record_field of [ `Expression of expression - | `Pattern of pattern ] - * Types.label_description - * Longident.t Location.loc - | Module_binding_name of module_binding - | Module_declaration_name of module_declaration + Structure_item of structure_item * Env.t + | Signature_item of signature_item * Env.t + | Module_binding of module_binding + | Value_binding of value_binding + | Module_type of module_type + | Module_declaration of module_declaration + | Module_type_declaration of module_type_declaration + | With_constraint of with_constraint + | Core_type of core_type + | Package_type of package_type + | Row_field of row_field + | Value_description of value_description + | Type_declaration of type_declaration + | Type_kind of type_kind + | Type_extension of type_extension + | Extension_constructor of extension_constructor + | Label_declaration of label_declaration + | Constructor_declaration of constructor_declaration + | Class_type of class_type + | Class_signature of class_signature + | Class_type_field of class_type_field + | Class_declaration of class_declaration + | Class_description of class_description + | Class_type_declaration of class_type_declaration + | Binding_op of binding_op + | Include_description of include_description + | Include_declaration of include_declaration + | Open_description of open_description + | Open_declaration of open_declaration + | Method_call of expression * meth * Location.t + | Record_field of + [ `Expression of expression | `Pattern of pattern ] + * Types.label_description + * Longident.t Location.loc + | Module_binding_name of module_binding + | Module_declaration_name of module_declaration | Module_type_declaration_name of module_type_declaration val fold_node : (Env.t -> node -> 'a -> 'a) -> Env.t -> node -> 'a -> 'a @@ -115,16 +113,17 @@ val string_of_node : node -> string val node_paths : node -> Path.t Location.loc list val node_paths_and_longident : node -> (Path.t Location.loc * Longident.t) list -val node_is_constructor : node -> +val node_is_constructor : + node -> [ `Description of Types.constructor_description | `Declaration of Typedtree.constructor_declaration | `Extension_constructor of Typedtree.extension_constructor ] - Location.loc option + Location.loc + option val node_of_binary_part : Env.t -> Cmt_format.binary_part -> node val all_holes : Env.t * node -> - (Location.t * - Env.t * - [`Exp of Types.type_expr | `Mod of Types.module_type]) list + (Location.t * Env.t * [ `Exp of Types.type_expr | `Mod of Types.module_type ]) + list diff --git a/src/ocaml/merlin_specific/tast_helper.ml b/src/ocaml/merlin_specific/tast_helper.ml index d9dead492..066620141 100644 --- a/src/ocaml/merlin_specific/tast_helper.ml +++ b/src/ocaml/merlin_specific/tast_helper.ml @@ -4,7 +4,7 @@ module Pat = struct let pat_extra = [] let pat_attributes = [] - let constant ?(loc=Location.none) pat_env pat_type c = + let constant ?(loc = Location.none) pat_env pat_type c = let pat_desc = Tpat_constant c in { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } @@ -17,24 +17,24 @@ module Pat = struct let pat_desc = Tpat_var (Ident.create_local str.Asttypes.txt, str, uid) in { pat_desc; pat_loc; pat_extra; pat_attributes; pat_type; pat_env } - let record ?(loc=Location.none) pat_env pat_type lst closed_flag = + let record ?(loc = Location.none) pat_env pat_type lst closed_flag = let pat_desc = Tpat_record (lst, closed_flag) in { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - let tuple ?(loc=Location.none) pat_env pat_type lst = + let tuple ?(loc = Location.none) pat_env pat_type lst = let pat_desc = Tpat_tuple lst in { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - let construct ?(loc=Location.none) - pat_env pat_type lid cstr_desc args locs_coretype = + let construct ?(loc = Location.none) pat_env pat_type lid cstr_desc args + locs_coretype = let pat_desc = Tpat_construct (lid, cstr_desc, args, locs_coretype) in { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - let pat_or ?(loc=Location.none) ?row_desc pat_env pat_type p1 p2 = + let pat_or ?(loc = Location.none) ?row_desc pat_env pat_type p1 p2 = let pat_desc = Tpat_or (p1, p2, row_desc) in { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } - let variant ?(loc=Location.none) pat_env pat_type lbl sub rd = + let variant ?(loc = Location.none) pat_env pat_type lbl sub rd = let pat_desc = Tpat_variant (lbl, sub, rd) in { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env } end diff --git a/src/ocaml/merlin_specific/typer_raw.ml b/src/ocaml/merlin_specific/typer_raw.ml index 26926f668..83a956f1b 100644 --- a/src/ocaml/merlin_specific/typer_raw.ml +++ b/src/ocaml/merlin_specific/typer_raw.ml @@ -1,40 +1,37 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) open Std let fresh_env () = (*Ident.reinit();*) let initially_opened_module = - if !Clflags.nopervasives then - None - else - Some "Stdlib" + if !Clflags.nopervasives then None else Some "Stdlib" in Typemod.initial_env ~loc:(Location.in_file "command line") diff --git a/src/ocaml/merlin_specific/typer_raw.mli b/src/ocaml/merlin_specific/typer_raw.mli index b6550aa7b..fe218286a 100644 --- a/src/ocaml/merlin_specific/typer_raw.mli +++ b/src/ocaml/merlin_specific/typer_raw.mli @@ -1,29 +1,29 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) val fresh_env : unit -> Env.t diff --git a/src/ocaml/parsing/.ocamlformat-enable b/src/ocaml/parsing/.ocamlformat-enable new file mode 100644 index 000000000..34e266974 --- /dev/null +++ b/src/ocaml/parsing/.ocamlformat-enable @@ -0,0 +1 @@ +msupport_parsing.ml diff --git a/src/ocaml/parsing/msupport_parsing.ml b/src/ocaml/parsing/msupport_parsing.ml index 567e5e28e..0a3fa6228 100644 --- a/src/ocaml/parsing/msupport_parsing.ml +++ b/src/ocaml/parsing/msupport_parsing.ml @@ -1,6 +1,4 @@ (* Filled in from Msupport. *) -let msupport_raise_error : (exn -> unit) ref = - ref raise +let msupport_raise_error : (exn -> unit) ref = ref raise -let raise_error exn = - !msupport_raise_error exn +let raise_error exn = !msupport_raise_error exn diff --git a/src/utils/.ocamlformat b/src/utils/.ocamlformat deleted file mode 100644 index e3346c163..000000000 --- a/src/utils/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable=true diff --git a/src/utils/.ocamlformat-enable b/src/utils/.ocamlformat-enable deleted file mode 100644 index a7338db29..000000000 --- a/src/utils/.ocamlformat-enable +++ /dev/null @@ -1,2 +0,0 @@ -msupport.ml -msupport.mli diff --git a/src/utils/.ocamlformat-ignore b/src/utils/.ocamlformat-ignore new file mode 100644 index 000000000..430454161 --- /dev/null +++ b/src/utils/.ocamlformat-ignore @@ -0,0 +1,4 @@ +misc.ml +misc.mli +stamped_hashtable.ml +stamped_hashtable.mli diff --git a/src/utils/file_cache.ml b/src/utils/file_cache.ml index 0ce83ef54..ad464082a 100644 --- a/src/utils/file_cache.ml +++ b/src/utils/file_cache.ml @@ -1,58 +1,60 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) -module Make(Input : sig +module Make (Input : sig type t val read : string -> t val cache_name : string -end) = struct - let {Logger. log} = Logger.for_section ("File_cache("^Input.cache_name^")") +end) = +struct + let { Logger.log } = + Logger.for_section ("File_cache(" ^ Input.cache_name ^ ")") - let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t - = Hashtbl.create 17 + let cache : (string, File_id.t * float ref * Input.t) Hashtbl.t = + Hashtbl.create 17 - type cache_stats = { hit: int; miss: int } + type cache_stats = { hit : int; miss : int } let cache_hit = ref 0 let cache_miss = ref 0 let get_cache_stats () = { hit = !cache_hit; miss = !cache_miss } let clear_cache_stats () = - cache_hit := 0; cache_miss := 0 + cache_hit := 0; + cache_miss := 0 let get_cached_entry ~title fid filename = let fid', latest_use, file = Hashtbl.find cache filename in - if (File_id.check fid fid') then ( + if File_id.check fid fid' then ( log ~title "reusing %S" filename; cache_hit := !cache_hit + 1) else ( log ~title "%S was updated on disk" filename; - raise Not_found; - ); + raise Not_found); latest_use := Unix.time (); file @@ -60,28 +62,29 @@ end) = struct let fid = File_id.get filename in let title = "read" in try get_cached_entry ~title fid filename - with Not_found -> - try - cache_miss := !cache_miss + 1; - log ~title "reading %S from disk" filename; - let file = Input.read filename in - Hashtbl.replace cache filename (fid, ref (Unix.time ()), file); - file - with exn -> - log ~title "failed to read %S (%t)" - filename (fun () -> Printexc.to_string exn); - Hashtbl.remove cache filename; - raise exn + with Not_found -> ( + try + cache_miss := !cache_miss + 1; + log ~title "reading %S from disk" filename; + let file = Input.read filename in + Hashtbl.replace cache filename (fid, ref (Unix.time ()), file); + file + with exn -> + log ~title "failed to read %S (%t)" filename (fun () -> + Printexc.to_string exn); + Hashtbl.remove cache filename; + raise exn) let check filename = let fid = File_id.get filename in match Hashtbl.find cache filename with | exception Not_found -> false - | (fid', latest_use, _) -> + | fid', latest_use, _ -> if File_id.check fid fid' then begin latest_use := Unix.time (); true - end else begin + end + else begin false end @@ -92,24 +95,21 @@ end) = struct let flush ?older_than () = let title = "flush" in - let limit = match older_than with + let limit = + match older_than with | None -> -.max_float | Some dt -> Unix.time () -. dt in let add_invalid filename (fid, latest_use, _) invalids = - if !latest_use > limit && - File_id.check (File_id.get filename) fid - then ( + if !latest_use > limit && File_id.check (File_id.get filename) fid then ( log ~title "keeping %S" filename; - invalids - ) else ( + invalids) + else ( log ~title "removing %S" filename; - filename :: invalids - ) + filename :: invalids) in let invalid = Hashtbl.fold add_invalid cache [] in List.iter (Hashtbl.remove cache) invalid - let clear () = - Hashtbl.clear cache + let clear () = Hashtbl.clear cache end diff --git a/src/utils/file_cache.mli b/src/utils/file_cache.mli index 5ea735405..3a82c7f5a 100644 --- a/src/utils/file_cache.mli +++ b/src/utils/file_cache.mli @@ -1,45 +1,45 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) module Make (Input : sig type t val read : string -> t val cache_name : string end) : sig - val read : string -> Input.t + val read : string -> Input.t val flush : ?older_than:float -> unit -> unit val clear : unit -> unit val check : string -> bool - val get_cached_entry : string -> Input.t (** @raises Not_found if the file is not in cache. *) + val get_cached_entry : string -> Input.t - type cache_stats = { hit: int; miss: int } + type cache_stats = { hit : int; miss : int } val get_cache_stats : unit -> cache_stats val clear_cache_stats : unit -> unit end diff --git a/src/utils/file_id.ml b/src/utils/file_id.ml index bcf9e6eeb..70069ca74 100644 --- a/src/utils/file_id.ml +++ b/src/utils/file_id.ml @@ -1,37 +1,45 @@ type t = Unix.stats let null_stat = - { Unix. - st_dev = -1; st_ino = -1; st_kind = Unix.S_REG; st_nlink = -1; - st_perm = -1; st_uid = -1; st_gid = -1; st_rdev = -1; st_size = -1; - st_atime = nan; st_mtime = nan; st_ctime = nan } + { Unix.st_dev = -1; + st_ino = -1; + st_kind = Unix.S_REG; + st_nlink = -1; + st_perm = -1; + st_uid = -1; + st_gid = -1; + st_rdev = -1; + st_size = -1; + st_atime = nan; + st_mtime = nan; + st_ctime = nan + } let get_res filename = try Result.ok @@ Unix.stat filename with _ -> Error ("Stat for" ^ filename ^ "couldn't be gathered") let get filename = - match get_res filename with Ok fn -> fn | Error _ -> null_stat + match get_res filename with + | Ok fn -> fn + | Error _ -> null_stat let check a b = - a == b || ( - (a != null_stat) && (b != null_stat) && - let open Unix in - a.st_mtime = b.st_mtime && - a.st_size = b.st_size && - a.st_ino = b.st_ino && - a.st_dev = b.st_dev - ) + a == b + || a != null_stat && b != null_stat + && + let open Unix in + a.st_mtime = b.st_mtime && a.st_size = b.st_size && a.st_ino = b.st_ino + && a.st_dev = b.st_dev let cache = ref None -let with_cache k = - Std.let_ref cache (Some (Hashtbl.create 7)) k +let with_cache k = Std.let_ref cache (Some (Hashtbl.create 7)) k let get filename = match !cache with | None -> get filename - | Some table -> + | Some table -> ( match Hashtbl.find table filename with | stats -> Logger.log ~section:"stat_cache" ~title:"reuse cache" "%s" filename; @@ -39,4 +47,4 @@ let get filename = | exception Not_found -> let stats = get filename in Hashtbl.add table filename stats; - stats + stats) diff --git a/src/utils/file_id.mli b/src/utils/file_id.mli index d045375c0..88cf3eaf4 100644 --- a/src/utils/file_id.mli +++ b/src/utils/file_id.mli @@ -1,20 +1,20 @@ -type t (** An instance of [t] represents the identity of the contents of a file path. Use this to quickly detect if a file has changed. (Detection is done by checking some fields from stat syscall, it can be tricked but should behave well in regular cases). FIXME: precision of mtime is still the second?! *) +type t -val check: t -> t -> bool (** Returns true iff the heuristic determines that the file contents has not changed. *) +val check : t -> t -> bool -val get: string -> t (** [file_id filename] computes an id for the current contents of [filename]. Returns a generic id, if the id can't be computed. *) +val get : string -> t -val get_res: string -> (t, string) Result.t (** Same as [get], but returns an error, if the id can't be computed. *) +val get_res : string -> (t, string) Result.t val with_cache : (unit -> 'a) -> 'a diff --git a/src/utils/lib_config.ml b/src/utils/lib_config.ml index 493124178..566f9c9c6 100644 --- a/src/utils/lib_config.ml +++ b/src/utils/lib_config.ml @@ -5,11 +5,9 @@ let set_program_name name = program_name := name let program_name () = !program_name module Json = struct - let set_pretty_to_string f = - Std.Json.pretty_to_string := f + let set_pretty_to_string f = Std.Json.pretty_to_string := f end module System = struct - let set_run_in_directory f = - Std.System.run_in_directory := f + let set_run_in_directory f = Std.System.run_in_directory := f end diff --git a/src/utils/lib_config.mli b/src/utils/lib_config.mli index 7516d49be..2725672f0 100644 --- a/src/utils/lib_config.mli +++ b/src/utils/lib_config.mli @@ -10,10 +10,10 @@ val set_program_name : string -> unit val program_name : unit -> string module Json : sig - (** Merlin's logger requires a Json pretty-printer for correct operation. + (** Merlin's logger requires a Json pretty-printer for correct operation. [set_pretty_to_string] can be used to provide one. A common pretifier is [Yojson.Basic.pretty_to_string]. *) - val set_pretty_to_string : (Std.json -> string) -> unit + val set_pretty_to_string : (Std.json -> string) -> unit end (** Merlin spawns child processes for preprocessors (pp and ppx), which can be @@ -41,15 +41,15 @@ module System : sig - As of today Merlin handles the [`Cancelled] return case identically as other error codes. *) - val set_run_in_directory - : (prog:string - -> prog_is_quoted:bool - -> args:string list - -> cwd:string - -> ?stdin:string - -> ?stdout:string - -> ?stderr:string - -> unit - -> [ `Finished of int | `Cancelled ]) - -> unit + val set_run_in_directory : + (prog:string -> + prog_is_quoted:bool -> + args:string list -> + cwd:string -> + ?stdin:string -> + ?stdout:string -> + ?stderr:string -> + unit -> + [ `Finished of int | `Cancelled ]) -> + unit end diff --git a/src/utils/logger.ml b/src/utils/logger.ml index c24d126f4..f695e7eb0 100644 --- a/src/utils/logger.ml +++ b/src/utils/logger.ml @@ -1,37 +1,36 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) open Std let time = ref 0.0 -let delta_time () = - Sys.time () -. !time +let delta_time () = Sys.time () -. !time let destination = ref None let selected_sections = ref None @@ -52,26 +51,25 @@ let log_flush () = let log ~section ~title fmt = match !destination with | Some oc when is_section_enabled section -> - Printf.ksprintf (fun str -> + Printf.ksprintf + (fun str -> output_section oc section title; if str <> "" then ( output_string oc str; - if str.[String.length str - 1] <> '\n' then - output_char oc '\n' - ) - ) fmt - | None | Some _ -> - Printf.ifprintf () fmt + if str.[String.length str - 1] <> '\n' then output_char oc '\n')) + fmt + | None | Some _ -> Printf.ifprintf () fmt let fmt_buffer = Buffer.create 128 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 @@ -81,15 +79,11 @@ let fmt () f = let json () f = match f () with | json -> !Json.pretty_to_string json - | exception exn -> - Printf.sprintf "Exception: %s" (Printexc.to_string exn) + | exception exn -> Printf.sprintf "Exception: %s" (Printexc.to_string exn) let exn () exn = Printexc.to_string exn -type notification = { - section: string; - msg: string; -} +type notification = { section : string; msg : string } let notifications : notification list ref option ref = ref None @@ -98,15 +92,15 @@ let notify ~section = log ~section ~title:"notify" "%s" msg; match !notifications with | None -> () - | Some r -> r := {section; msg} :: !r + | Some r -> r := { section; msg } :: !r in Printf.ksprintf tell -let with_notifications r f = - let_ref notifications (Some r) f +let with_notifications r f = let_ref notifications (Some r) f let with_sections sections f = - let sections = match sections with + let sections = + match sections with | [] -> None | sections -> let table = Hashtbl.create (List.length sections) in @@ -116,25 +110,29 @@ let with_sections sections f = let sections0 = !selected_sections in selected_sections := sections; match f () with - | result -> selected_sections := sections0; result - | exception exn -> selected_sections := sections0; reraise exn + | result -> + selected_sections := sections0; + result + | exception exn -> + selected_sections := sections0; + reraise exn -let with_log_file file ?(sections=[]) f = +let with_log_file file ?(sections = []) f = match file with | None -> with_sections sections f - | Some file -> + | Some file -> ( log_flush (); - let destination', release = match file with + let destination', release = + match file with | "" -> (None, ignore) | "-" -> (Some stderr, ignore) - | filename -> + | filename -> ( match open_out filename with | exception exn -> - Printf.eprintf "cannot open %S for logging: %s" - filename (Printexc.to_string exn); + Printf.eprintf "cannot open %S for logging: %s" filename + (Printexc.to_string exn); (None, ignore) - | oc -> - (Some oc, (fun () -> close_out_noerr oc)) + | oc -> (Some oc, fun () -> close_out_noerr oc)) in let destination0 = !destination in destination := destination'; @@ -144,8 +142,12 @@ let with_log_file file ?(sections=[]) f = release () in match with_sections sections f with - | v -> release (); v - | exception exn -> release (); reraise exn + | v -> + release (); + v + | exception exn -> + release (); + reraise exn) type 'a printf = title:string -> ('a, unit, string, unit) format4 -> 'a type logger = { log : 'a. 'a printf } diff --git a/src/utils/logger.mli b/src/utils/logger.mli index 13bbc22de..4b50468da 100644 --- a/src/utils/logger.mli +++ b/src/utils/logger.mli @@ -1,30 +1,30 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) (** Log module * @@ -35,19 +35,16 @@ * **) -val log - : section:string -> title:string -> ('b, unit, string, unit) format4 -> 'b +val log : + section:string -> title:string -> ('b, unit, string, unit) format4 -> 'b -val fmt : unit -> (Format.formatter -> unit) -> string +val fmt : unit -> (Format.formatter -> unit) -> string val json : unit -> (unit -> Std.json) -> string -val exn : unit -> exn -> string +val exn : unit -> exn -> string val log_flush : unit -> unit -type notification = { - section: string; - msg: string; -} +type notification = { section : string; msg : string } val notify : section:string -> ('b, unit, string, unit) format4 -> 'b val with_notifications : notification list ref -> (unit -> 'a) -> 'a diff --git a/src/utils/marg.ml b/src/utils/marg.ml index 4b6641866..58ab0ad39 100644 --- a/src/utils/marg.ml +++ b/src/utils/marg.ml @@ -2,36 +2,33 @@ open Std (** {1 Flag parsing utils} *) -type 'a t = string list -> 'a -> (string list * 'a) +type 'a t = string list -> 'a -> string list * 'a type 'a table = (string, 'a t) Hashtbl.t -let unit f : 'a t = fun args acc -> (args, (f acc)) +let unit f : 'a t = fun args acc -> (args, f acc) -let param ptype f : 'a t = fun args acc -> +let param ptype f : 'a t = + fun args acc -> match args with | [] -> failwith ("expects a " ^ ptype ^ " argument") - | arg :: args -> args, f arg acc + | arg :: args -> (args, f arg acc) -let unit_ignore : 'a t = - fun x -> unit (fun x -> x) x +let unit_ignore : 'a t = fun x -> unit (fun x -> x) x -let param_ignore = - fun x -> param "string" (fun _ x -> x) x +let param_ignore x = param "string" (fun _ x -> x) x -let bool f = param "bool" - (function - | "yes" | "y" | "Y" | "true" | "True" | "1" -> f true - | "no" | "n" | "N" | "false" | "False" | "0" -> f false - | str -> - failwithf "expecting boolean (%s), got %S." - "yes|y|Y|true|1 / no|n|N|false|0" - str - ) +let bool f = + param "bool" (function + | "yes" | "y" | "Y" | "true" | "True" | "1" -> f true + | "no" | "n" | "N" | "false" | "False" | "0" -> f false + | str -> + failwithf "expecting boolean (%s), got %S." + "yes|y|Y|true|1 / no|n|N|false|0" str) type docstring = string -type 'a spec = (string * docstring * 'a t) +type 'a spec = string * docstring * 'a t let rec assoc3 key = function | [] -> raise Not_found @@ -45,52 +42,55 @@ let rec mem_assoc3 key = function let parse_one ~warning global_spec local_spec args global local = match args with | [] -> None - | arg :: args -> + | arg :: args -> ( match Hashtbl.find global_spec arg with - | action -> begin match action args global with - | (args, global) -> - Some (args, global, local) - | exception (Failure msg) -> - warning ("flag " ^ arg ^ " " ^ msg); - Some (args, global, local) - | exception exn -> - warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn); - Some (args, global, local) - end - | exception Not_found -> + | action -> begin + match action args global with + | args, global -> Some (args, global, local) + | exception Failure msg -> + warning ("flag " ^ arg ^ " " ^ msg); + Some (args, global, local) + | exception exn -> + warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn); + Some (args, global, local) + end + | exception Not_found -> ( match assoc3 arg local_spec with - | action -> begin match action args local with - | (args, local) -> - Some (args, global, local) - | exception (Failure msg) -> + | action -> begin + match action args local with + | args, local -> Some (args, global, local) + | exception Failure msg -> warning ("flag " ^ arg ^ " " ^ msg); Some (args, global, local) | exception exn -> warning ("flag " ^ arg ^ ": error, " ^ Printexc.to_string exn); Some (args, global, local) end - | exception Not_found -> None + | exception Not_found -> None)) let parse_all ~warning global_spec local_spec = let rec normal_parsing args global local = match parse_one ~warning global_spec local_spec args global local with | Some (args, global, local) -> normal_parsing args global local - | None -> match args with + | None -> ( + match args with | arg :: args -> begin (* We split on the first '=' to check if the argument was of the form name=value *) try let name, value = Misc.cut_at arg '=' in - normal_parsing (name::value::args) global local + normal_parsing (name :: value :: args) global local with Not_found -> warning ("unknown flag " ^ arg); resume_parsing args global local - end - | [] -> (global, local) + end + | [] -> (global, local)) and resume_parsing args global local = - let args = match args with - | arg :: args when not (Hashtbl.mem global_spec arg || - mem_assoc3 arg local_spec) -> args + let args = + match args with + | arg :: args + when not (Hashtbl.mem global_spec arg || mem_assoc3 arg local_spec) -> + args | args -> args in normal_parsing args global local diff --git a/src/utils/marg.mli b/src/utils/marg.mli index ae3fb2765..f86719969 100644 --- a/src/utils/marg.mli +++ b/src/utils/marg.mli @@ -35,7 +35,7 @@ val param_ignore : 'acc t type docstring = string -type 'a spec = (string * docstring * 'a t) +type 'a spec = string * docstring * 'a t (** Consume at most one flag from the list, returning updated state or [None] in case of failure. @@ -43,14 +43,20 @@ type 'a spec = (string * docstring * 'a t) use. *) val parse_one : warning:(string -> unit) -> - 'global table -> 'local spec list -> - string list -> 'global -> 'local -> + 'global table -> + 'local spec list -> + string list -> + 'global -> + 'local -> (string list * 'global * 'local) option (** Consume all arguments from the input list, calling warning for incorrect ones and resuming parsing after. *) val parse_all : warning:(string -> unit) -> - 'global table -> 'local spec list -> - string list -> 'global -> 'local -> + 'global table -> + 'local spec list -> + string list -> + 'global -> + 'local -> 'global * 'local diff --git a/src/utils/ppxsetup.ml b/src/utils/ppxsetup.ml index 885a3241b..e426bd9cf 100644 --- a/src/utils/ppxsetup.ml +++ b/src/utils/ppxsetup.ml @@ -1,73 +1,68 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) open Std -type t = { - ppxs: string list; - ppxopts: string list list String.Map.t; -} +type t = { ppxs : string list; ppxopts : string list list String.Map.t } let empty = { ppxs = []; ppxopts = String.Map.empty } let add_ppx ppx t = - if List.mem ppx ~set:t.ppxs - then t - else {t with ppxs = ppx :: t.ppxs} + if List.mem ppx ~set:t.ppxs then t else { t with ppxs = ppx :: t.ppxs } let add_ppxopts ppx opts t = match opts with | [] -> t | opts -> let ppx = Filename.basename ppx in - let optss = - try String.Map.find ppx t.ppxopts - with Not_found -> [] - in + let optss = try String.Map.find ppx t.ppxopts with Not_found -> [] in if not (List.mem ~set:optss opts) then let ppxopts = String.Map.add ~key:ppx ~data:(opts :: optss) t.ppxopts in - {t with ppxopts} + { t with ppxopts } else t let union ta tb = { ppxs = List.filter_dup (ta.ppxs @ tb.ppxs); - ppxopts = String.Map.merge ~f:(fun _ a b -> match a, b with - | v, None | None, v -> v - | Some a, Some b -> Some (List.filter_dup (a @ b))) + ppxopts = + String.Map.merge + ~f:(fun _ a b -> + match (a, b) with + | v, None | None, v -> v + | Some a, Some b -> Some (List.filter_dup (a @ b))) ta.ppxopts tb.ppxopts } let command_line t = - List.fold_right ~f:(fun ppx ppxs -> + List.fold_right + ~f:(fun ppx ppxs -> let basename = Filename.basename ppx in let opts = - try String.Map.find basename t.ppxopts - with Not_found -> [] + try String.Map.find basename t.ppxopts with Not_found -> [] in let opts = List.concat (List.rev opts) in String.concat ~sep:" " (ppx :: opts) :: ppxs) @@ -76,16 +71,13 @@ let command_line t = let dump t = let string k = `String k in let string_list l = `List (List.map ~f:string l) in - `Assoc [ - "preprocessors", - string_list t.ppxs; - "options", - `Assoc ( - String.Map.fold - ~f:(fun ~key ~data:opts acc -> - let opts = List.rev_map ~f:string_list opts in - (key, `List opts) :: acc) - ~init:[] - t.ppxopts - ) - ] + `Assoc + [ ("preprocessors", string_list t.ppxs); + ( "options", + `Assoc + (String.Map.fold + ~f:(fun ~key ~data:opts acc -> + let opts = List.rev_map ~f:string_list opts in + (key, `List opts) :: acc) + ~init:[] t.ppxopts) ) + ] diff --git a/src/utils/ppxsetup.mli b/src/utils/ppxsetup.mli index b1758c9de..e3517c3ec 100644 --- a/src/utils/ppxsetup.mli +++ b/src/utils/ppxsetup.mli @@ -1,39 +1,39 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) type t -val empty: t -val add_ppx: string -> t -> t -val add_ppxopts: string -> string list -> t -> t +val empty : t +val add_ppx : string -> t -> t +val add_ppxopts : string -> string list -> t -> t -val union: t -> t -> t +val union : t -> t -> t -val command_line: t -> string list +val command_line : t -> string list val dump : t -> Std.json diff --git a/src/utils/sexp.ml b/src/utils/sexp.ml index ddff64148..85f4f7b18 100644 --- a/src/utils/sexp.ml +++ b/src/utils/sexp.ml @@ -1,9 +1,9 @@ type t = - | Cons of t * t - | Sym of string + | Cons of t * t + | Sym of string | String of string - | Int of int - | Float of float + | Int of int + | Float of float let nil = Sym "nil" @@ -17,16 +17,13 @@ let escaped str = done; let buf = Buffer.create (len + !extra_chars + 2) in Buffer.add_char buf '"'; - if !extra_chars = 0 then ( - Buffer.add_string buf str - ) else ( + if !extra_chars = 0 then Buffer.add_string buf str + else for i = 0 to len - 1 do let c = str.[i] in - if c = '"' || c = '\\' then - Buffer.add_char buf '\\'; + if c = '"' || c = '\\' then Buffer.add_char buf '\\'; Buffer.add_char buf c done; - ); Buffer.add_char buf '"'; Buffer.contents buf @@ -46,27 +43,27 @@ let unescaped str = let i = ref 0 in while !i < len do 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 - end; - incr i - ) + | '\\' -> + 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 + end; + incr i | c -> Buffer.add_char buf c; incr i @@ -78,18 +75,18 @@ let rec of_list = function | a :: tl -> Cons (a, of_list tl) let rec tell_sexp tell = function - | Cons (a,b) -> + | Cons (a, b) -> tell "("; tell_sexp tell a; tell_cons tell b - | Sym s -> tell s + | Sym s -> tell s | String s -> tell (escaped s) - | Int i -> tell (string_of_int i) - | Float f -> tell (string_of_float f) + | Int i -> tell (string_of_int i) + | Float f -> tell (string_of_float f) and tell_cons tell = function | Sym "nil" -> tell ")" - | Cons (a,b) -> + | Cons (a, b) -> tell " "; tell_sexp tell a; tell_cons tell b @@ -98,39 +95,33 @@ and tell_cons tell = function tell_sexp tell sexp; tell ")" -let is_alpha c = - (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') +let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') -let is_num c = - (c >= '0' && c <= '9' || c == '-') +let is_num c = (c >= '0' && c <= '9') || c == '-' let is_alphanum c = is_alpha c || is_num c let read_sexp getch = let buf = Buffer.create 10 in let rec read_sexp getch = function - | ' ' | '\t' | '\n' -> - read_sexp getch (getch ()) - - | c when is_num c -> - read_num getch c - - | '\'' | ':' | '_' as c -> read_sym getch (Some c) + | ' ' | '\t' | '\n' -> read_sexp getch (getch ()) + | c when is_num c -> read_num getch c + | ('\'' | ':' | '_') as c -> read_sym getch (Some c) | c when is_alpha c -> read_sym getch (Some c) - - | '"' -> - read_string getch + | '"' -> read_string getch | '\000' -> raise End_of_file | '(' -> let lhs, next = read_sexp getch (getch ()) in read_cons getch (fun rhs -> Cons (lhs, rhs)) next | _ -> failwith "Invalid parse" - and read_cons getch k next = - match (match next with Some c -> c | None -> getch ()) with + match + match next with + | Some c -> c + | None -> getch () + with | ' ' | '\t' | '\n' -> read_cons getch k None - | ')' -> k nil, None + | ')' -> (k nil, None) | '.' -> let rhs, next = read_sexp getch (getch ()) in let rec aux = function @@ -138,34 +129,35 @@ let read_sexp getch = | ' ' | '\t' | '\n' -> aux (getch ()) | _ -> failwith "Invalid parse" in - begin match next with - | Some c -> aux c - | None -> aux (getch ()) - end, None + ( begin + match next with + | Some c -> aux c + | None -> aux (getch ()) + end, + None ) | c -> let cell, next = read_sexp getch c in read_cons getch (fun rhs -> k (Cons (cell, rhs))) next - and read_num getch c = Buffer.clear buf; Buffer.add_char buf c; let rec aux ~is_start ~is_float = match getch () with | '-' when is_start -> - Buffer.add_char buf c; aux ~is_start:false ~is_float + Buffer.add_char buf c; + aux ~is_start:false ~is_float | c when c >= '0' && c <= '9' -> - Buffer.add_char buf c; aux ~is_start:false ~is_float - | '.' | 'e' | 'E' as c -> - Buffer.add_char buf c; aux ~is_start:false ~is_float:true + Buffer.add_char buf c; + aux ~is_start:false ~is_float + | ('.' | 'e' | 'E') as c -> + Buffer.add_char buf c; + aux ~is_start:false ~is_float:true | c -> let s = Buffer.contents buf in - (if is_float - then Float (float_of_string s) - else Int (int_of_string s)), - Some c + ( (if is_float then Float (float_of_string s) else Int (int_of_string s)), + Some c ) in aux ~is_start:true ~is_float:false - and read_string getch = Buffer.clear buf; let rec aux () = @@ -175,32 +167,33 @@ let read_sexp getch = Buffer.add_char buf '\\'; Buffer.add_char buf (getch ()); aux () - | '"' -> - String (unescaped (Buffer.contents buf)), None + | '"' -> (String (unescaped (Buffer.contents buf)), None) | c -> Buffer.add_char buf c; aux () in aux () - and read_sym getch next = Buffer.clear buf; let rec aux next = - match (match next with Some c -> c | None -> getch ()) with + match + match next with + | Some c -> c + | None -> getch () + with | ('\'' | '-' | ':' | '_') as c -> Buffer.add_char buf c; aux None | c when is_alphanum c -> Buffer.add_char buf c; aux None - | c -> Sym (Buffer.contents buf), Some c + | c -> (Sym (Buffer.contents buf), Some c) in aux next in read_sexp getch (getch ()) -let to_buf sexp buf = - tell_sexp (Buffer.add_string buf) sexp +let to_buf sexp buf = tell_sexp (Buffer.add_string buf) sexp let to_string sexp = let buf = Buffer.create 100 in @@ -213,35 +206,32 @@ let getch_of_substring str pos len = invalid_arg "Sexp.getch_of_substring"; let pos = ref pos in let getch () = - if !pos < len then + if !pos < len then ( let r = str.[!pos] in incr pos; - r + r) else '\000' in getch -let getch_of_string str = - getch_of_substring str 0 (String.length str) +let getch_of_string str = getch_of_substring str 0 (String.length str) -let of_string str = - fst (read_sexp (getch_of_string str)) +let of_string str = fst (read_sexp (getch_of_string str)) let getch_of_subbytes str pos len = let len = pos + len in - if pos < 0 || len > Bytes.length str then - invalid_arg "Sexp.getch_of_subbytes"; + if pos < 0 || len > Bytes.length str then invalid_arg "Sexp.getch_of_subbytes"; let pos = ref pos in let getch () = - if !pos < len then + if !pos < len then ( let r = Bytes.get str !pos in incr pos; - r + r) else '\000' in getch -let of_file_descr ?(on_read=ignore) fd = +let of_file_descr ?(on_read = ignore) fd = let getch = ref (fun () -> '\000') in let rest = ref None in let buffer = Bytes.create 1024 in @@ -250,18 +240,17 @@ let of_file_descr ?(on_read=ignore) fd = | Some r -> rest := None; r - | None -> + | None -> ( match !getch () with | '\000' -> on_read fd; let read = Unix.read fd buffer 0 1024 in if read = 0 then '\000' - else - begin - getch := getch_of_subbytes buffer 0 read; - !getch () - end - | c -> c + else begin + getch := getch_of_subbytes buffer 0 read; + !getch () + end + | c -> c) in fun () -> try @@ -274,21 +263,20 @@ let of_channel ?on_read ic = of_file_descr ?on_read (Unix.descr_of_in_channel ic) let rec of_json = - let assoc_item (a,b) = Cons (Sym a, of_json b) in + let assoc_item (a, b) = Cons (Sym a, of_json b) in function - | `Null -> Sym "null" - | `Int i -> Int i - | `Float f -> Float f - | `String s -> String s - | `Bool true -> Sym "true" + | `Null -> Sym "null" + | `Int i -> Int i + | `Float f -> Float f + | `String s -> String s + | `Bool true -> Sym "true" | `Bool false -> Sym "false" - | `Assoc lst -> Cons (Cons (Sym "assoc", Sym "nil"), of_list (List.map assoc_item lst)) - | `List lst -> of_list (List.map of_json lst) + | `Assoc lst -> + Cons (Cons (Sym "assoc", Sym "nil"), of_list (List.map assoc_item lst)) + | `List lst -> of_list (List.map of_json lst) let rec to_json = - let fail msg sexp = - failwith (msg ^ ", got: \n" ^ to_string sexp) - in + let fail msg sexp = failwith (msg ^ ", got: \n" ^ to_string sexp) in let rec assoc_item = function | Cons (Cons (Sym a, b), c) -> (a, to_json b) :: assoc_item c | Sym "nil" -> [] @@ -300,14 +288,13 @@ let rec to_json = | sexp -> fail "expecting list" sexp in function - | Sym "null" -> `Null - | Sym "true" -> `Bool true + | Sym "null" -> `Null + | Sym "true" -> `Bool true | Sym "false" -> `Bool false - | Int i -> `Int i - | Float f -> `Float f + | Int i -> `Int i + | Float f -> `Float f | String s -> `String s - | Cons (Cons (Sym "assoc", Sym "nil"), assocs) -> - `Assoc (assoc_item assocs) + | Cons (Cons (Sym "assoc", Sym "nil"), assocs) -> `Assoc (assoc_item assocs) | Sym "nil" -> `List [] | Cons (hd, tl) -> `List (to_json hd :: list_items tl) | Sym s -> `String s diff --git a/src/utils/sexp.mli b/src/utils/sexp.mli index 3801f3ead..bd738b036 100644 --- a/src/utils/sexp.mli +++ b/src/utils/sexp.mli @@ -1,7 +1,7 @@ open Std type t = - Cons of t * t + | Cons of t * t | Sym of string | String of string | Int of int diff --git a/src/utils/std.ml b/src/utils/std.ml index 465a95ec7..0457d87a3 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -1,39 +1,39 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors + This file is part of Merlin, an helper for ocaml editors - Copyright (C) 2013 - 2015 Frédéric Bour - Thomas Refis - Simon Castellan + Copyright (C) 2013 - 2015 Frédéric Bour + Thomas Refis + Simon Castellan - Permission is hereby granted, free of charge, to any person obtaining a - copy of this software and associated documentation files (the "Software"), - to deal in the Software without restriction, including without limitation the - rights to use, copy, modify, merge, publish, distribute, sublicense, and/or - sell copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: + Permission is hereby granted, free of charge, to any person obtaining a + copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - The Software is provided "as is", without warranty of any kind, express or - implied, including but not limited to the warranties of merchantability, - fitness for a particular purpose and noninfringement. In no event shall - the authors or copyright holders be liable for any claim, damages or other - liability, whether in an action of contract, tort or otherwise, arising - from, out of or in connection with the software or the use or other dealings - in the Software. + The Software is provided "as is", without warranty of any kind, express or + implied, including but not limited to the warranties of merchantability, + fitness for a particular purpose and noninfringement. In no event shall + the authors or copyright holders be liable for any claim, damages or other + liability, whether in an action of contract, tort or otherwise, arising + from, out of or in connection with the software or the use or other dealings + in the Software. -)* }}} *) + )* }}} *) type json = -[ `Assoc of (string * json) list -| `Bool of bool -| `Float of float -| `Int of int -| `List of json list -| `Null -| `String of string ] + [ `Assoc of (string * json) list + | `Bool of bool + | `Float of float + | `Int of int + | `List of json list + | `Null + | `String of string ] module Json = struct type t = json @@ -46,23 +46,20 @@ module Json = struct | None -> `Null | Some x -> f x - let list f x = - `List (List.map f x) + let list f x = `List (List.map f x) - let pretty_to_string : (t -> string) ref = ref @@ fun _ -> + let pretty_to_string : (t -> string) ref = + ref @@ fun _ -> Printf.sprintf - "Logger error: `Std.Json.pretty_to_string` \ - is not set. You should initialize that reference with the \ - pretifier of your choice to enable json logging. \ - A common one is `Yojson.Basic.pretty_to_string`." + "Logger error: `Std.Json.pretty_to_string` is not set. You should \ + initialize that reference with the pretifier of your choice to enable \ + json logging. A common one is `Yojson.Basic.pretty_to_string`." end module Hashtbl = struct include Hashtbl - let find_some tbl key = - try Some (find tbl key) - with Not_found -> None + let find_some tbl key = try Some (find tbl key) with Not_found -> None let elements tbl = Hashtbl.fold (fun _key elt acc -> elt :: acc) tbl [] @@ -87,18 +84,16 @@ module List = struct in aux 0 l - let find_some ~f l = - try Some (find ~f l) - with Not_found -> None + let find_some ~f l = try Some (find ~f l) with Not_found -> None - let rec rev_scan_left acc ~f l ~init = match l with + let rec rev_scan_left acc ~f l ~init = + match l with | [] -> acc | x :: xs -> let init = f init x in rev_scan_left (init :: acc) ~f xs ~init - let scan_left ~f l ~init = - List.rev (rev_scan_left [] ~f l ~init) + let scan_left ~f l ~init = List.rev (rev_scan_left [] ~f l ~init) let rev_filter ~f lst = let rec aux acc = function @@ -109,33 +104,33 @@ module List = struct let rec filter_map ~f = function | [] -> [] - | x :: xs -> + | x :: xs -> ( match f x with | None -> filter_map ~f xs - | Some x -> x :: filter_map ~f xs + | Some x -> x :: filter_map ~f xs) let rec find_map ~f = function | [] -> raise Not_found - | x :: xs -> + | x :: xs -> ( match f x with | None -> find_map ~f xs - | Some x' -> x' + | Some x' -> x') let rec map_end ~f l1 l2 = match l1 with | [] -> l2 - | hd::tl -> f hd :: map_end ~f tl l2 + | hd :: tl -> f hd :: map_end ~f tl l2 let concat_map ~f l = flatten (map ~f l) let replicate elem n = let rec aux acc elem n = - if n <= 0 then acc else aux (elem :: acc) elem (n-1) + if n <= 0 then acc else aux (elem :: acc) elem (n - 1) in aux [] elem n - let rec remove ?(phys=false) x = - let check = if phys then (==) else (=) in + let rec remove ?(phys = false) x = + let check = if phys then ( == ) else ( = ) in function | [] -> [] | hd :: tl when check x hd -> tl @@ -146,9 +141,10 @@ module List = struct | hd :: tl when x = hd -> remove_all x tl | hd :: tl -> hd :: remove_all x tl - let rec same ~f l1 l2 = match l1, l2 with + let rec same ~f l1 l2 = + match (l1, l2) with | [], [] -> true - | (hd1 :: tl1), (hd2 :: tl2) when f hd1 hd2 -> same ~f tl1 tl2 + | hd1 :: tl1, hd2 :: tl2 when f hd1 hd2 -> same ~f tl1 tl2 | _, _ -> false (* [length_lessthan n l] returns @@ -166,20 +162,21 @@ module List = struct let tbl = Hashtbl.create 17 in let f a b = let b' = equiv b in - if Hashtbl.mem tbl b' - then a - else (Hashtbl.add tbl b' (); b :: a) + if Hashtbl.mem tbl b' then a + else ( + Hashtbl.add tbl b' (); + b :: a) in rev (fold_left ~f ~init:[] lst) let filter_dup lst = filter_dup' ~equiv:(fun x -> x) lst let rec merge_cons ~f = function - | a :: ((b :: tl) as tl') -> - begin match f a b with - | Some a' -> merge_cons ~f (a' :: tl) - | None -> a :: merge_cons ~f tl' - end + | a :: (b :: tl as tl') -> begin + match f a b with + | Some a' -> merge_cons ~f (a' :: tl) + | None -> a :: merge_cons ~f tl' + end | tl -> tl let rec take_while ~f = function @@ -201,98 +198,98 @@ module List = struct let rec split_n acc n = function | x :: xs when n > 0 -> split_n (x :: acc) (n - 1) xs - | xs -> List.rev acc, xs + | xs -> (List.rev acc, xs) let split_n n l = split_n [] n l let rec split3 xs ys zs = function - | (x,y,z) :: tl -> split3 (x :: xs) (y :: ys) (z :: zs) tl - | [] -> List.rev xs, List.rev ys, List.rev zs + | (x, y, z) :: tl -> split3 (x :: xs) (y :: ys) (z :: zs) tl + | [] -> (List.rev xs, List.rev ys, List.rev zs) let split3 l = split3 [] [] [] l - let rec unfold ~f a = match f a with + let rec unfold ~f a = + match f a with | None -> [] | Some a -> a :: unfold ~f a - let rec rev_unfold acc ~f a = match f a with + let rec rev_unfold acc ~f a = + match f a with | None -> acc | Some a -> rev_unfold (a :: acc) ~f a let rec fold_n_map ~f ~init = function - | [] -> init, [] + | [] -> (init, []) | x :: xs -> let acc, x' = f init x in let acc, xs' = fold_n_map ~f ~init:acc xs in - acc, (x' :: xs') + (acc, x' :: xs') let rec iteri2 i ~f l1 l2 = match (l1, l2) with - ([], []) -> () - | (a1::l1, a2::l2) -> f i a1 a2; iteri2 (i + 1) ~f l1 l2 - | (_, _) -> raise (Invalid_argument "iteri2") + | [], [] -> () + | a1 :: l1, a2 :: l2 -> + f i a1 a2; + iteri2 (i + 1) ~f l1 l2 + | _, _ -> raise (Invalid_argument "iteri2") let iteri2 ~f l1 l2 = iteri2 0 ~f l1 l2 module Lazy = struct - type 'a t = - | Nil - | Cons of 'a * 'a t lazy_t + type 'a t = Nil | Cons of 'a * 'a t lazy_t let rec map ~f = function | Nil -> Nil - | Cons (hd,tl) -> - Cons (f hd, lazy (map ~f (Lazy.force tl))) + | Cons (hd, tl) -> Cons (f hd, lazy (map ~f (Lazy.force tl))) let rec to_strict = function | Nil -> [] - | Cons (hd, lazy tl) -> hd :: to_strict tl + | Cons (hd, (lazy tl)) -> hd :: to_strict tl - let rec unfold f a = match f a with + let rec unfold f a = + match f a with | None -> Nil | Some a -> Cons (a, lazy (unfold f a)) let rec filter_map ~f = function | Nil -> Nil - | Cons (a, tl) -> match f a with + | Cons (a, tl) -> ( + match f a with | None -> filter_map ~f (Lazy.force tl) - | Some a' -> Cons (a', lazy (filter_map ~f (Lazy.force tl))) + | Some a' -> Cons (a', lazy (filter_map ~f (Lazy.force tl)))) end let rec last = function | [] -> None - | [x] -> Some x + | [ x ] -> Some x | _ :: l -> last l let rec group_by pred group acc = function | [] -> List.rev acc - | x :: xs -> + | x :: xs -> ( match group with - | (x' :: _) when pred x x' -> - group_by pred (x :: group) acc xs - | _ -> group_by pred [x] (group :: acc) xs + | x' :: _ when pred x x' -> group_by pred (x :: group) acc xs + | _ -> group_by pred [ x ] (group :: acc) xs) let group_by pred xs = match group_by pred [] [] xs with | [] :: xs | xs -> xs (* Merge sorted lists *) - let rec merge ~cmp l1 l2 = match l1, l2 with + let rec merge ~cmp l1 l2 = + match (l1, l2) with | l, [] | [], l -> l - | (x1 :: _), (x2 :: x2s) when cmp x1 x2 > 0 -> - x2 :: merge ~cmp l1 x2s - | x1 :: x1s, _ -> - x1 :: merge ~cmp x1s l2 + | x1 :: _, x2 :: x2s when cmp x1 x2 > 0 -> x2 :: merge ~cmp l1 x2s + | x1 :: x1s, _ -> x1 :: merge ~cmp x1s l2 let rec dedup_adjacent ~cmp = function | x1 :: (x2 :: _ as xs) when cmp x1 x2 = 0 -> dedup_adjacent ~cmp xs - | x :: xs -> x :: dedup_adjacent ~cmp xs + | x :: xs -> x :: dedup_adjacent ~cmp xs | [] -> [] (* [sort_uniq] does not need to maintain a set of seen entries because duplicates will be adjacent. *) let sort_uniq ~cmp l = dedup_adjacent ~cmp (sort ~cmp l) - let print f () l = - "[ " ^ String.concat "; " (List.map (f ()) l) ^ " ]" + let print f () l = "[ " ^ String.concat "; " (List.map (f ()) l) ^ " ]" end module Option = struct @@ -321,27 +318,29 @@ module Option = struct | None -> () | Some x -> f x - let cons o xs = match o with + let cons o xs = + match o with | None -> xs | Some x -> x :: xs module Infix = struct - let return x = Some x - let (>>=) x f = bind x ~f - let (>>|) x f = map x ~f + let return x = Some x + let ( >>= ) x f = bind x ~f + let ( >>| ) x f = map x ~f end include Infix let to_list = function | None -> [] - | Some x -> [x] + | Some x -> [ x ] let is_some = function | None -> false | _ -> true - let plus a b = match a with + let plus a b = + match a with | Some _ -> a | None -> b @@ -362,24 +361,21 @@ module String = struct let for_all f t = let len = String.length t in - let rec loop i = - i = len || (f t.[i] && loop (i + 1)) - in + let rec loop i = i = len || (f t.[i] && loop (i + 1)) in loop 0 - let reverse s1 = let len = length s1 in - let s2 = Bytes.make len 'a' in + let s2 = Bytes.make len 'a' in for i = 0 to len - 1 do Bytes.set s2 i s1.[len - i - 1] - done ; + done; Bytes.to_string s2 let common_prefix_len s1 s2 = let rec aux i = - if i >= length s1 || i >= length s2 || s1.[i] <> s2.[i] then i else - aux (succ i) + if i >= length s1 || i >= length s2 || s1.[i] <> s2.[i] then i + else aux (succ i) in aux 0 @@ -387,72 +383,85 @@ module String = struct let is_prefixed ~by = let l = String.length by in fun s -> - 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) + 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 (* Drop characters from beginning of string *) let drop n s = sub s ~pos:n ~len:(length s - n) - module Set = struct - include MoreLabels.Set.Make (struct type t = string let compare = compare end) + include MoreLabels.Set.Make (struct + type t = string + let compare = compare + end) let of_list l = List.fold_left ~f:(fun s elt -> add elt s) l ~init:empty let to_list s = fold ~f:(fun x xs -> x :: xs) s ~init:[] end module Map = struct - include MoreLabels.Map.Make (struct type t = string let compare = compare end) + include MoreLabels.Map.Make (struct + type t = string + let compare = compare + end) let of_list l = - List.fold_left ~f:(fun m (k,v) -> add ~key:k ~data:v m) l ~init:empty - let to_list m = fold ~f:(fun ~key ~data xs -> (key,data) :: xs) m ~init:[] + List.fold_left ~f:(fun m (k, v) -> add ~key:k ~data:v m) l ~init:empty + let to_list m = fold ~f:(fun ~key ~data xs -> (key, data) :: xs) m ~init:[] - let keys m = fold ~f:(fun ~key ~data:_ xs -> key :: xs) m ~init:[] + let keys m = fold ~f:(fun ~key ~data:_ xs -> key :: xs) m ~init:[] let values m = fold ~f:(fun ~key:_ ~data xs -> data :: xs) m ~init:[] let add_multiple key data t = - let current = - try find key t - with Not_found -> [] - in + let current = try find key t with Not_found -> [] in let data = data :: current in add ~key ~data t end let mem c s = - try ignore (String.index s c : int); true + try + ignore (String.index s c : int); + true with Not_found -> false let first_double_underscore_end s = let len = String.length s in let rec aux i = - if i > len - 2 then raise Not_found else - if s.[i] = '_' && s.[i + 1] = '_' then i + 1 + if i > len - 2 then raise Not_found + else if s.[i] = '_' && s.[i + 1] = '_' then i + 1 else aux (i + 1) in aux 0 let no_double_underscore s = - try ignore (first_double_underscore_end s); false + try + ignore (first_double_underscore_end s); + false with Not_found -> true - let trim = function "" -> "" | str -> - let l = String.length str in - let is_space = function - | ' ' | '\n' | '\t' | '\r' -> true - | _ -> false - in - let r0 = ref 0 and rl = ref l in - while !r0 < l && is_space str.[!r0] do incr r0 done; - let r0 = !r0 in - while !rl > r0 && is_space str.[!rl - 1] do decr rl done; - let rl = !rl in - if r0 = 0 && rl = l then str else sub str ~pos:r0 ~len:(rl - r0) + let trim = function + | "" -> "" + | str -> + let l = String.length str in + let is_space = function + | ' ' | '\n' | '\t' | '\r' -> true + | _ -> false + in + let r0 = ref 0 and rl = ref l in + while !r0 < l && is_space str.[!r0] do + incr r0 + done; + let r0 = !r0 in + while !rl > r0 && is_space str.[!rl - 1] do + decr rl + done; + let rl = !rl in + if r0 = 0 && rl = l then str else sub str ~pos:r0 ~len:(rl - r0) let print () s = Printf.sprintf "%S" s @@ -464,11 +473,11 @@ module String = struct let split_on_char_ c s = match String.index s c with - | exception Not_found -> [s] + | exception Not_found -> [ s ] | p -> let rec loop i = match String.index_from s i c with - | exception Not_found -> [String.sub s i (String.length s - i)] + | exception Not_found -> [ String.sub s i (String.length s - i) ] | j -> let s0 = String.sub s i (j - i) in s0 :: loop (j + 1) @@ -486,25 +495,23 @@ module String = struct done; Some (String.sub text plen (tlen - plen)) with Not_found -> None - else - None + else None let next_occurrence ~pattern text from = let plen = String.length pattern in let last = String.length text - plen in let i = ref from and j = ref 0 in while !i <= last && !j < plen do - if text.[!i + !j] <> pattern.[!j] - then (incr i; j := 0) + if text.[!i + !j] <> pattern.[!j] then ( + incr i; + j := 0) else incr j done; - if !j < plen then - raise Not_found - else - !i + if !j < plen then raise Not_found else !i let replace_all ~pattern ~with_ text = - if pattern = "" then text else + if pattern = "" then text + else match next_occurrence ~pattern text 0 with | exception Not_found -> text | j0 -> @@ -532,9 +539,7 @@ module String = struct let len = String.length s in match from with | None -> len - 1 - | Some i -> - if i > len - 1 then failwith "rfindi: invalid from" - else i + | Some i -> if i > len - 1 then failwith "rfindi: invalid from" else i in loop s ~f from @@ -560,7 +565,7 @@ module Format = struct let default_width = ref 0 - let to_string ?(width= !default_width) () = + let to_string ?(width = !default_width) () = let b = Buffer.create 32 in let ppf = formatter_of_buffer b in let contents () = @@ -568,23 +573,22 @@ module Format = struct Buffer.contents b in pp_set_margin ppf width; - ppf, contents + (ppf, contents) end module Lexing = struct + type position = Lexing.position = + { pos_fname : string; pos_lnum : int; pos_bol : int; pos_cnum : int } - type position = Lexing.position = { - pos_fname : string; - pos_lnum : int; - pos_bol : int; - pos_cnum : int; - } - - include (Lexing : module type of struct include Lexing end - with type position := position) + include ( + Lexing : + module type of struct + include Lexing + end + with type position := position) let move buf p = - buf.lex_abs_pos <- (p.pos_cnum - buf.lex_curr_pos); + buf.lex_abs_pos <- p.pos_cnum - buf.lex_curr_pos; buf.lex_curr_p <- p let from_strings ?empty ?position source refill = @@ -594,34 +598,35 @@ module Lexing = struct let lex_fun buf size = let count = min (!len - !pos) size in let count = - if count <= 0 then - begin - source := refill (); - len := String.length !source; - pos := 0; - min !len size - end + if count <= 0 then begin + source := refill (); + len := String.length !source; + pos := 0; + min !len size + end else count in if count <= 0 then 0 else begin - String.blit ~src:!source ~src_pos:!pos ~dst:buf ~dst_pos:0 ~len:count; - pos := !pos + count; - (match empty with None -> () | Some r -> r := !pos >= !len); - count - end + String.blit ~src:!source ~src_pos:!pos ~dst:buf ~dst_pos:0 ~len:count; + pos := !pos + count; + (match empty with + | None -> () + | Some r -> r := !pos >= !len); + count + end in let buf = from_function lex_fun in Option.iter ~f:(move buf) position; buf (* Manipulating position *) - let make_pos ?(pos_fname="") (pos_lnum, pos_cnum) = - { pos_fname ; pos_lnum ; pos_cnum ; pos_bol = 0 } + let make_pos ?(pos_fname = "") (pos_lnum, pos_cnum) = + { pos_fname; pos_lnum; pos_cnum; pos_bol = 0 } let column pos = pos.pos_cnum - pos.pos_bol - let set_column pos col = {pos with pos_cnum = pos.pos_bol + col} + let set_column pos col = { pos with pos_cnum = pos.pos_bol + col } let split_pos pos = (pos.pos_lnum, column pos) @@ -637,21 +642,18 @@ module Lexing = struct (* Current position in lexer, even if the buffer is in the middle of a refill operation *) let immediate_pos buf = - {buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos} + { buf.lex_curr_p with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos } let json_of_position pos = let line, col = split_pos pos in - `Assoc ["line", `Int line; "col", `Int col] + `Assoc [ ("line", `Int line); ("col", `Int col) ] - let min_pos p1 p2 = - if compare_pos p1 p2 <= 0 then p1 else p2 + let min_pos p1 p2 = if compare_pos p1 p2 <= 0 then p1 else p2 - let max_pos p1 p2 = - if compare_pos p1 p2 >= 0 then p1 else p2 + let max_pos p1 p2 = if compare_pos p1 p2 >= 0 then p1 else p2 end module Char = struct - (* FIXME: Remove once we drop support for 4.02 and replace the calls to [uppercase] and [lowercase] by their [_ascii] version. *) [@@@ocaml.warning "-3"] @@ -664,17 +666,11 @@ module Char = struct end module Glob : sig - type pattern = - | Wildwild - | Exact of string - | Regexp of Str.regexp + type pattern = Wildwild | Exact of string | Regexp of Str.regexp val compile_pattern : string -> pattern val match_pattern : pattern -> string -> bool end = struct - type pattern = - | Wildwild - | Exact of string - | Regexp of Str.regexp + type pattern = Wildwild | Exact of string | Regexp of Str.regexp let compile_pattern = function | "**" -> Wildwild @@ -684,27 +680,31 @@ end = struct let flush () = if Buffer.length chunk > 0 then ( Buffer.add_string regexp (Str.quote (Buffer.contents chunk)); - Buffer.clear chunk; - ) + Buffer.clear chunk) in 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 '.'; + 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; - if Buffer.length regexp = 0 then - Exact (Buffer.contents chunk) + if Buffer.length regexp = 0 then Exact (Buffer.contents chunk) else ( flush (); Buffer.add_char regexp '$'; - Regexp (Str.regexp (Buffer.contents regexp)) - ) + Regexp (Str.regexp (Buffer.contents regexp))) let match_pattern re str = match re with @@ -716,7 +716,7 @@ end let fprintf = Format.fprintf let lazy_eq a b = - match Lazy.is_val a, Lazy.is_val b with + match (Lazy.is_val a, Lazy.is_val b) with | true, true -> Lazy.force_val a == Lazy.force_val b | false, false -> a == b | _ -> false @@ -725,8 +725,12 @@ let let_ref r v f = let v' = !r in r := v; match f () with - | result -> r := v'; result - | exception exn -> r := v'; raise exn + | result -> + r := v'; + result + | exception exn -> + r := v'; + raise exn let failwithf fmt = Printf.ksprintf failwith fmt @@ -734,20 +738,19 @@ module Shell = struct let split_command str = let comps = ref [] in let dirty = ref false in - let buf = Buffer.create 16 in + let buf = Buffer.create 16 in let flush () = if !dirty then ( comps := Buffer.contents buf :: !comps; dirty := false; - Buffer.clear buf; - ) + Buffer.clear buf) in let i = ref 0 and len = String.length str in let unescape = function | 'n' -> '\n' | 'r' -> '\r' | 't' -> '\t' - | x -> x + | x -> x in while !i < len do let c = str.[!i] in @@ -758,26 +761,23 @@ module Shell = struct dirty := true; if !i < len then ( Buffer.add_char buf (unescape str.[!i]); - incr i - ) + incr i) | '\'' -> dirty := true; while !i < len && str.[!i] <> '\'' do Buffer.add_char buf str.[!i]; - incr i; + incr i done; incr i | '"' -> dirty := true; while !i < len && str.[!i] <> '"' do (match str.[!i] with - | '\\' -> - incr i; - if !i < len then - Buffer.add_char buf (unescape str.[!i]); - | x -> Buffer.add_char buf x - ); - incr i; + | '\\' -> + incr i; + if !i < len then Buffer.add_char buf (unescape str.[!i]) + | x -> Buffer.add_char buf x); + incr i done; incr i | x -> @@ -789,69 +789,75 @@ module Shell = struct end module System = struct - external windows_merlin_system_command : string -> cwd:string -> ?outfile:string -> int = - "ml_merlin_system_command" - - let run_in_directory - : (prog:string - -> prog_is_quoted:bool - -> args:string list - -> cwd:string - -> ?stdin:string - -> ?stdout:string - -> ?stderr:string - -> unit - -> [ `Finished of int | `Cancelled ]) ref = ref @@ - fun ~prog ~prog_is_quoted:_ ~args ~cwd ?stdin:_ ?stdout ?stderr:_ () -> - (* Currently we assume that [prog] is always quoted and might contain - arguments such as [-as-ppx]. This is due to the way Merlin gets its - configuration. Thus we cannot rely on [Filename.quote_command]. *) - let args = String.concat ~sep:" " @@ List.map ~f:Filename.quote args in - (* Runned program should never output on stdout since it is the - channel used by Merlin to communicate with the editor *) - let args = - if Sys.win32 then args - else - let stdout = match stdout with - | Some file -> Filename.quote file - | None -> "&2" - in - Printf.sprintf "%s 1>%s" args stdout - in - let cmd = Format.sprintf "%s %s" prog args in - let exit_code = - if Sys.win32 then - (* Note: the following function will never output to stdout. - When [stdout = None], stdout is sent to stderr. *) - windows_merlin_system_command cmd ~cwd ?outfile:stdout - else - Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd) - in - `Finished exit_code + external windows_merlin_system_command : + string -> cwd:string -> ?outfile:string -> int = "ml_merlin_system_command" + + let run_in_directory : + (prog:string -> + prog_is_quoted:bool -> + args:string list -> + cwd:string -> + ?stdin:string -> + ?stdout:string -> + ?stderr:string -> + unit -> + [ `Finished of int | `Cancelled ]) + ref = + ref + @@ fun ~prog ~prog_is_quoted:_ ~args ~cwd ?stdin:_ ?stdout ?stderr:_ () -> + (* Currently we assume that [prog] is always quoted and might contain + arguments such as [-as-ppx]. This is due to the way Merlin gets its + configuration. Thus we cannot rely on [Filename.quote_command]. *) + let args = String.concat ~sep:" " @@ List.map ~f:Filename.quote args in + (* Runned program should never output on stdout since it is the + channel used by Merlin to communicate with the editor *) + let args = + if Sys.win32 then args + else + let stdout = + match stdout with + | Some file -> Filename.quote file + | None -> "&2" + in + Printf.sprintf "%s 1>%s" args stdout + in + let cmd = Format.sprintf "%s %s" prog args in + let exit_code = + if Sys.win32 then + (* Note: the following function will never output to stdout. + When [stdout = None], stdout is sent to stderr. *) + windows_merlin_system_command cmd ~cwd ?outfile:stdout + else Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd) + in + `Finished exit_code end - (* [modules_in_path ~ext path] lists ocaml modules corresponding to - * filenames with extension [ext] in given [path]es. - * For instance, if there is file "a.ml","a.mli","b.ml" in ".": - * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"], - * - modules_in_path ~ext:".mli" ["."] returns ["A"] *) +(* [modules_in_path ~ext path] lists ocaml modules corresponding to + * filenames with extension [ext] in given [path]es. + * For instance, if there is file "a.ml","a.mli","b.ml" in ".": + * - modules_in_path ~ext:".ml" ["."] returns ["A";"B"], + * - 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 + ~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 @@ -874,15 +880,9 @@ let file_contents filename = external reraise : exn -> 'a = "%reraise" -type 'a with_workdir = { - workdir : string; - workval : 'a; -} (** Some value that must be interpreted with respect to a specific work directory. (e.g. for resolving relative paths or executing sub-commands *) +type 'a with_workdir = { workdir : string; workval : 'a } let dump_with_workdir f x : json = - `Assoc [ - "workdir", `String x.workdir; - "workval", f x.workval; - ] + `Assoc [ ("workdir", `String x.workdir); ("workval", f x.workval) ]