diff --git a/plugins/ocp-lint-plugin-text/build.ocp b/plugins/ocp-lint-plugin-text/build.ocp index 712a685..ce5f34b 100644 --- a/plugins/ocp-lint-plugin-text/build.ocp +++ b/plugins/ocp-lint-plugin-text/build.ocp @@ -28,6 +28,7 @@ begin library "ocp-lint-plugin-text" "code_length.ml" "useless_space.ml" "not_that_char.ml" + "duplicate_code.ml" ] requires = [ "ocp-lint-config" diff --git a/plugins/ocp-lint-plugin-text/duplicate_code.ml b/plugins/ocp-lint-plugin-text/duplicate_code.ml new file mode 100644 index 0000000..b7fcd66 --- /dev/null +++ b/plugins/ocp-lint-plugin-text/duplicate_code.ml @@ -0,0 +1,76 @@ +open Plugin_text + +module Linter = Plugin.MakeLint(struct + let name = "duplicate code" + let version = "1" + let short_name = "duplicated_code" + let details = + "Detect portions of code that duplicated" + let enabled = true + end) + +type warning = + | CodeDuplicated of string + + +let w_code_duplicated = Linter.new_warning + ~id:1 + ~short_name:"dupli_code" + ~msg:"Duplicated code detected in $file " + ~severity:10 + + +module Warnings = Linter.MakeWarnings(struct + type t = warning + + let to_warning = function + | CodeDuplicated name -> w_code_duplicated, ["file",name] + end) + +let read_entire_file filename = + let file = open_in filename in + let file_length = in_channel_length file in + let str = Bytes.create file_length in + really_input file str 0 file_length; + close_in file; + Bytes.unsafe_to_string(str) + +let remove_char regexp replace str = + Str.global_replace regexp replace str + + +let rec get_length_file input_c acc = + let line = try [input_line input_c] with End_of_file -> [] in + match line with + | [] -> acc + | [line] -> get_length_file input_c (1+acc) + | _ -> failwith "weird things not a line" + +let make_portions regex content = + let part = Str.split (Str.regexp regex) content in + List.map (remove_char (Str.regexp "[\n\t ]+") "") part + +let hash_portions portions = + List.map (function e -> Digest.string e) portions + +let rec check_duplicate acc l = match l with + | [] -> acc + | (x,p)::tl -> if(p) then check_duplicate (1 + acc) tl else check_duplicate acc tl + + +let compare_ el l = List.map (function e -> (e,(el = e))) l + + +let rec if_duplicate_portions portions = match portions with + | [] -> failwith "nothing to compare" + | [em] -> false + | hd::tl -> if((check_duplicate 0 (compare_ hd tl)) > 0) then true else if_duplicate_portions tl + +let check_file file = + let portions = hash_portions (make_portions "^\\s*$" (read_entire_file file)) in + if(if_duplicate_portions portions) then Warnings.report_file file (CodeDuplicated file) + else () + + module MainSRC = Linter.MakeInputML(struct + let main source = check_file source + end) diff --git a/plugins/ocp-lint-plugin-typedtree/build.ocp b/plugins/ocp-lint-plugin-typedtree/build.ocp index 656d3ad..f7254a2 100644 --- a/plugins/ocp-lint-plugin-typedtree/build.ocp +++ b/plugins/ocp-lint-plugin-typedtree/build.ocp @@ -32,6 +32,12 @@ begin library "ocp-lint-plugin-typedtree" "checkInheritance.ml" "checkModuleUtilization.ml" (pp = "ocp-pp") "polymorphic_comparison.ml" + "must_a_int.ml"; + "check_order_args.ml"; + "mutable_ref.ml"; + "lengthy_tuples.ml"; + + ] requires = [ "ocp-lint-config" diff --git a/plugins/ocp-lint-plugin-typedtree/check_order_args.ml b/plugins/ocp-lint-plugin-typedtree/check_order_args.ml new file mode 100644 index 0000000..42c6038 --- /dev/null +++ b/plugins/ocp-lint-plugin-typedtree/check_order_args.ml @@ -0,0 +1,174 @@ +module Linter = Plugin_typedtree.Plugin.MakeLint(struct + let name = "Detect bad use of arguments when functions are called" + let version = "1" + let short_name = "arg_func_order" + let details = "check if function called, are called with their arguments in good order" + let enabled = true; + end) + +type warning = BadUseArg of (string * string * string) + + + +let w_badusearg = Linter.new_warning + ~id:1 + ~short_name:"arg_func_order" + ~msg:"'$func' have arguments with same types, ($good) -> $err_msg" + ~severity:9 + +let err_file ?file:(file = "err.txt") str = + let oc = open_out file in Printf.fprintf oc "(%s) \n" str; + close_out oc;; + +let rec concat_el l acc = match l with + | [] -> acc + | head::tail -> concat_el tail (acc^" "^head) + + +let rec key_exist l key = match l with + [] -> false + | (typ,_,_)::tl -> if key = typ then true else key_exist tl key + +let rec create_keys l acc = match l with + [] -> acc + | (label,typ) :: tl -> if(key_exist acc typ) then create_keys tl acc else create_keys tl ([(typ,0,0)] @ acc) + + +let rec cumulative l map = match l with + |[] -> map + |(label,typ) :: tl -> cumulative tl (List.map (function (t,occur,occur_label) -> if typ = t then + if label = "labelled" then + (t,occur+1,occur_label+1) + else + (t,occur+1,occur_label) + else + (t,occur,occur_label)) map) + + +module Warnings = Linter.MakeWarnings(struct + type t = warning + let to_warning = function + | BadUseArg (good_order,func,types) -> w_badusearg, [("good",good_order );("func",func);("err_msg",types)] + end) + +let get_string data = match data with + | None -> "none" + | Some str -> str + +let rec check_path p acc = let open Path in match p with + | Pident (ident) -> acc ^ ident.name + | Pdot (t,str,ent) -> check_path t acc^str + | Papply (t_,t__) -> "Papply" + + +let get_arg_label arg = let open Asttypes in match arg with + | Nolabel -> "nolabel" + | Labelled (str) -> "labelled" + | Optional (str) -> "optional" + + +(* + t -> le type_expr desc + types -> la liste de couple (type,label) avec label qui peut prendre 3 valeur : nolabel, labelled, optional + label -> la variable temporaire qui sert a stocker le label courant (vu que la fonction est recursive j'ai besoin de garder cette valeur la jusqu'au cas terminaux ou je l'ajoute a la liste (type,label) + +*) + +let rec matching_type t map_types label = let open Typedtree in let open Types in match t.desc with + | Tvar (data) -> map_types @ [(label,get_string data)] + | Tarrow (arg_label,arg_type,result_type,_) -> let arg_type = matching_type arg_type [] (get_arg_label arg_label) in + let map_types = map_types @ arg_type in matching_type result_type map_types "" + + | Ttuple (t_list) -> get_type_args t_list map_types label + | Tconstr (path,t_list,_) -> map_types @ [(label,check_path path "")] + | Tobject (_,_) -> [("","tobject")] + | Tfield (_,_,_,_) -> [("","tfield")] + | Tnil -> [("","tnil")] + | Tlink (link) -> matching_type link map_types label + | Tsubst (_) -> [("","tsubst")] + | Tvariant (_) -> [("","tvariant")] + | Tunivar (_) -> [("","tunivar")] + | Tpoly (_,_) -> [("","tpoly")] + | Tpackage (_,_,_) -> [("","tpackage")] + +(* + Fonction mutuellement recursive avec matching type, car dans le cas de Tconstr on peut avoir a parser une liste de type_expr donc je l'envoie ici. +*) + +and get_type_args t acc label = let open Typedtree in let open Types in match t with + | [] -> acc + | hd::tl -> get_type_args tl (matching_type hd acc label) label + + +let get_type_func val_bind = let open Typedtree in match val_bind.vb_expr.exp_type.desc with + | Tvar (data) -> [("","tvar")] + | Tarrow (arg_label,arg_type,result_type,commut) -> let arg_type = matching_type arg_type [] (get_arg_label arg_label) in let map_types = arg_type @ [] in matching_type result_type map_types "" + | Ttuple (t_list) -> [("","ttuple")] + | Tconstr (path,t_list,_) -> [("","tconstr")] + | Tobject (_,_) -> [("","tobject")] + | Tfield (_,_,_,_) -> [("","tfield")] + | Tnil -> [("","tnil")] + | Tlink (link) -> matching_type link [] "" + | Tsubst (_) -> [("","tsubst")] + | Tvariant (_) -> [("","tvariant")] + | Tunivar (_) -> [("","tunivar")] + | Tpoly (_,_) -> [("","tpoly")] + | Tpackage (_,_,_) -> [("","tpackage")] + +let get_func_name pat = let open Typedtree in let open Asttypes in match pat.vb_pat.pat_desc with + | Tpat_var (ident,name_loc) -> (name_loc.txt,name_loc.loc) + | _ -> ("",pat.vb_loc) + +let next_case case = let open Typedtree in match case.c_rhs.exp_desc with + | Texp_function (record) -> List.hd record.cases + | _ -> case + +let rec iter_cases case acc = let open Typedtree in match case.c_lhs.pat_desc with + | Tpat_var (ident,loc) -> if(next_case(case) = case) then acc @ [ident.name] else iter_cases (next_case(case)) (acc @ [ident.name]) + | _ -> acc + +(* + cette fonction sert a me couper la liste (type,label) pour ne garder que les type des arguments et non le type de sortie, car quand je parse le type de la fonction je récupère tout (argument,sortie). + n elements de la liste l sont transféré dans le tableau acc. +*) + +let rec sub_list l n acc = match n with + | 0 -> acc + | _ -> sub_list (List.tl l) (n-1) (acc @ [List.hd l]) + +let get_args_name val_bind = let open Typedtree in match val_bind.vb_expr.exp_desc with + | Texp_function (record) -> iter_cases (List.hd record.cases) [] + | _ -> [] + +let get_args_type val_bind = let open Typedtree in match val_bind.vb_expr.exp_desc with + | Texp_function (record) -> sub_list (get_type_func val_bind) (List.length (iter_cases(List.hd record.cases) [])) [] + | _ -> [] + +let rec get_err_msg assoc acc = match assoc with + [] -> acc + | (typ,occur_t,occur_label)::tl -> if occur_t > occur_label then get_err_msg tl (acc ^""^string_of_int(occur_t)^" "^typ^" found but "^string_of_int(occur_label)^" labelled. ") else get_err_msg tl acc + +let iter = + let module IterExp = struct + include Typedtree_iter.DefaultIteratorArgument + + let enter_structure_item strct = + let open Typedtree in + let open Asttypes in + + + begin match strct.str_desc with + | Tstr_value (rec_flag, binding) -> List.iter (function binding -> let args_name = get_args_name binding in let args_type = get_args_type binding in + let (txt,loc) = get_func_name binding in + let assoc_t = cumulative args_type (create_keys args_type []) in + if((get_err_msg assoc_t "") <> "None") + then + Warnings.report loc (BadUseArg ((concat_el args_name ""),txt,(get_err_msg assoc_t "")))) binding + | _ -> () + end + end in + (module IterExp : Typedtree_iter.IteratorArgument) + +module Main = Linter.MakeInputCMT(struct + let main cmt = Typedtree_iter.iter_structure iter cmt +end) diff --git a/plugins/ocp-lint-plugin-typedtree/lengthy_tuples.ml b/plugins/ocp-lint-plugin-typedtree/lengthy_tuples.ml new file mode 100644 index 0000000..43204a3 --- /dev/null +++ b/plugins/ocp-lint-plugin-typedtree/lengthy_tuples.ml @@ -0,0 +1,67 @@ +module Linter = Plugin_typedtree.Plugin.MakeLint(struct + let name = "Detects lengthy tuples.Rationale: When a tuple has too many members, it should be refactored into a record" + let version = "1" + let short_name = "lengthy_tuples" + let details = "blabla" + let enabled = true; + end) + +type warning = TupleTooLong of (string * int) + +let limit = 2;; + + +let w_toolongtuple = Linter.new_warning + ~id:1 + ~short_name:"tuple too long" + ~msg:"the tuple '$var' have '$params' elements, the limit is $limit, When a tuple has too many members, it should be refactored into a record" + ~severity:5 + + +module Warnings = Linter.MakeWarnings(struct + type t = warning + let to_warning = function + | TupleTooLong (var,nb_parms) -> w_toolongtuple, [("var",var);("params",string_of_int nb_parms);("limit",string_of_int limit)] + + end) + + +let get_pattern pat = + let open Typedtree in + let open Location in + begin + match pat.vb_pat.pat_desc with + | Tpat_var (ident,var) -> (var.loc,var.txt) + | _ -> (pat.vb_loc,"") + end + + +let iter_exp exp = + let open Typedtree in + begin + match exp.vb_expr.exp_desc with + | Texp_tuple l -> List.length l + | _ -> 0 + end + + +let check_length_tuples bind = if ((iter_exp bind) > limit) then let (loc,txt) = get_pattern bind in Warnings.report loc (TupleTooLong(txt,iter_exp bind)) + + +let iter = + let module IterExp = struct + open Typedtree + open Asttypes + include Typedtree_iter.DefaultIteratorArgument + + let enter_structure_item strct = + begin match strct.str_desc with + | Tstr_value (rec_flag, binding) -> List.iter check_length_tuples binding + | _ -> () + end + end in + (module IterExp : Typedtree_iter.IteratorArgument) + +module Main = Linter.MakeInputCMT(struct + let main cmt = Typedtree_iter.iter_structure iter cmt +end) diff --git a/plugins/ocp-lint-plugin-typedtree/mutable_ref.ml b/plugins/ocp-lint-plugin-typedtree/mutable_ref.ml new file mode 100644 index 0000000..6fefdb1 --- /dev/null +++ b/plugins/ocp-lint-plugin-typedtree/mutable_ref.ml @@ -0,0 +1,92 @@ +module Linter = Plugin_typedtree.Plugin.MakeLint(struct + + let name = "justify use of ref/mutable field" + let version = "1" + let short_name = "mut_ref" + let details = "Justifier l'utilisation de valeurs mutables. Les protéger par un des mécanismes d'encapsulation recommandés" + let enabled = true; + end) + +type warning = MutableField of string | Ref_use of string + +let w_mutable = Linter.new_warning + ~id:1 + ~short_name:"mutable use" + ~msg:"you use a mutable field '$mut'" + ~severity:3 + +let w_reference = Linter.new_warning + ~id:2 + ~short_name:"ref use" + ~msg: "you use a ref with $p" + ~severity:3 + + +module Warnings = Linter.MakeWarnings(struct + type t = warning + + let to_warning = function + | MutableField mut -> w_mutable, ["mut",mut] + | Ref_use rf -> w_reference, ["p",rf] +end) + + +let err_file funct = + let oc = open_out "err.txt" in Printf.fprintf oc "im in %d " funct; + close_out oc;; + +let if_mutable lab = + let open Asttypes in + begin match lab with + | Immutable -> false + | Mutable -> true + end;; + +let parse_list l = + let open Typedtree in + begin match l.typ_kind with + | Ttype_record v -> let p = List.hd v in if (if_mutable p.ld_mutable) + then Warnings.report p.ld_name.loc (MutableField p.ld_name.txt) else () + | _ -> () + end + +let longident_ li = + let open Longident in + begin match li with + | Lident v -> v + | _ -> "pattern" + end + +let parse_exp_ident exp = + let open Typedtree in + begin match exp.exp_desc with + | Texp_ident (path_t,longident,val_desc) -> let name = longident_ (longident.txt) in let loc = longident.loc in Warnings.report loc ( Ref_use name) + | _ -> () + end + + +let parse_val_binding vb = + let open Typedtree in + begin match vb.vb_expr.exp_desc with + | Texp_apply (exp,l) -> parse_exp_ident exp (*Texp_apply of exp * (arg_label * exp_opt) list*) + | _ -> () + end + + +let iter = + let module IterExp = struct + open Typedtree + open Asttypes + include Typedtree_iter.DefaultIteratorArgument + + let enter_structure_item stru = match stru.str_desc with + | Tstr_type (rec_flag,type_decl) -> List.iter parse_list type_decl + | Tstr_value (rec_flag,val_binding) -> List.iter parse_val_binding val_binding + | _ -> () + + end in + (module IterExp : Typedtree_iter.IteratorArgument) + +module Main = Linter.MakeInputCMT(struct + let main cmt = Typedtree_iter.iter_structure iter cmt + end) diff --git a/tests_me/args/args_same_types.cmi b/tests_me/args/args_same_types.cmi new file mode 100644 index 0000000..eaa10d1 Binary files /dev/null and b/tests_me/args/args_same_types.cmi differ diff --git a/tests_me/args/args_same_types.cmo b/tests_me/args/args_same_types.cmo new file mode 100644 index 0000000..639a137 Binary files /dev/null and b/tests_me/args/args_same_types.cmo differ diff --git a/tests_me/args/args_same_types.cmt b/tests_me/args/args_same_types.cmt new file mode 100644 index 0000000..30be4a6 Binary files /dev/null and b/tests_me/args/args_same_types.cmt differ diff --git a/tests_me/args/args_same_types.ml b/tests_me/args/args_same_types.ml new file mode 100644 index 0000000..5242b53 --- /dev/null +++ b/tests_me/args/args_same_types.ml @@ -0,0 +1 @@ +let func arg1 ~n:arg2 ~j:arg3 arg4 arg5 = (int_of_string(arg4),int_of_string(arg5),arg2+1,arg1+.1.0,arg3+8) diff --git a/tests_me/duplicate/.DS_Store b/tests_me/duplicate/.DS_Store new file mode 100644 index 0000000..5008ddf Binary files /dev/null and b/tests_me/duplicate/.DS_Store differ diff --git a/tests_me/duplicate/second_victim.ml b/tests_me/duplicate/second_victim.ml new file mode 100644 index 0000000..9ff0aeb --- /dev/null +++ b/tests_me/duplicate/second_victim.ml @@ -0,0 +1,5 @@ +hey + +hey + +dsldkk diff --git a/tests_me/duplicate/victim_io.ml b/tests_me/duplicate/victim_io.ml new file mode 100644 index 0000000..bbc8720 --- /dev/null +++ b/tests_me/duplicate/victim_io.ml @@ -0,0 +1,11 @@ +(*let x = function x -> x +1*) + +let neg e = match e with true -> false | false -> true + +let neg e = match e with true -> false | false ->true + +let rec sort = function + | [] -> [] + | x :: l -> insert x (sort l) and insert elem = function + | [] -> [elem] + | x :: l -> if elem < x then elem :: x :: l else x :: insert elem l;; diff --git a/tests_me/ref/args_same_types.ml b/tests_me/ref/args_same_types.ml new file mode 100644 index 0000000..5242b53 --- /dev/null +++ b/tests_me/ref/args_same_types.ml @@ -0,0 +1 @@ +let func arg1 ~n:arg2 ~j:arg3 arg4 arg5 = (int_of_string(arg4),int_of_string(arg5),arg2+1,arg1+.1.0,arg3+8) diff --git a/tests_me/ref_mutable/mutable.cmi b/tests_me/ref_mutable/mutable.cmi new file mode 100644 index 0000000..1251397 Binary files /dev/null and b/tests_me/ref_mutable/mutable.cmi differ diff --git a/tests_me/ref_mutable/mutable.cmo b/tests_me/ref_mutable/mutable.cmo new file mode 100644 index 0000000..fd5181a Binary files /dev/null and b/tests_me/ref_mutable/mutable.cmo differ diff --git a/tests_me/ref_mutable/mutable.cmt b/tests_me/ref_mutable/mutable.cmt new file mode 100644 index 0000000..3feac2a Binary files /dev/null and b/tests_me/ref_mutable/mutable.cmt differ diff --git a/tests_me/ref_mutable/mutable.ml b/tests_me/ref_mutable/mutable.ml new file mode 100644 index 0000000..09e578a --- /dev/null +++ b/tests_me/ref_mutable/mutable.ml @@ -0,0 +1 @@ +type test = {mutable nop : int} diff --git a/tests_me/ref_mutable/mutable2.cmi b/tests_me/ref_mutable/mutable2.cmi new file mode 100644 index 0000000..fb4c601 Binary files /dev/null and b/tests_me/ref_mutable/mutable2.cmi differ diff --git a/tests_me/ref_mutable/mutable2.cmo b/tests_me/ref_mutable/mutable2.cmo new file mode 100644 index 0000000..6c061f5 Binary files /dev/null and b/tests_me/ref_mutable/mutable2.cmo differ diff --git a/tests_me/ref_mutable/mutable2.cmt b/tests_me/ref_mutable/mutable2.cmt new file mode 100644 index 0000000..a6cfb05 Binary files /dev/null and b/tests_me/ref_mutable/mutable2.cmt differ diff --git a/tests_me/ref_mutable/mutable2.ml b/tests_me/ref_mutable/mutable2.ml new file mode 100644 index 0000000..bc66fdd --- /dev/null +++ b/tests_me/ref_mutable/mutable2.ml @@ -0,0 +1 @@ +type man = { mutable test : int } diff --git a/tests_me/tuple/tuples.cmi b/tests_me/tuple/tuples.cmi new file mode 100644 index 0000000..267e404 Binary files /dev/null and b/tests_me/tuple/tuples.cmi differ diff --git a/tests_me/tuple/tuples.cmo b/tests_me/tuple/tuples.cmo new file mode 100644 index 0000000..ae62a62 Binary files /dev/null and b/tests_me/tuple/tuples.cmo differ diff --git a/tests_me/tuple/tuples.cmt b/tests_me/tuple/tuples.cmt new file mode 100644 index 0000000..9fd63d1 Binary files /dev/null and b/tests_me/tuple/tuples.cmt differ diff --git a/tests_me/tuple/tuples.ml b/tests_me/tuple/tuples.ml new file mode 100644 index 0000000..122768c --- /dev/null +++ b/tests_me/tuple/tuples.ml @@ -0,0 +1 @@ +let x = (1, 2, 3.)