diff options
52 files changed, 1705 insertions, 899 deletions
diff --git a/bin/args.ml b/bin/args.ml index 1503d18..e0e1419 100644 --- a/bin/args.ml +++ b/bin/args.ml @@ -29,7 +29,9 @@ let disable_module modules identifier = String.sub identifier ~pos:1 ~len:(String.length identifier - 1) in List.iter modules ~f:(fun t -> - let (module C : Qsp_syntax.S.Analyzer) = Qsp_checks.Check.get_module t in + let (module C : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module t + in if String.equal C.identifier identifier then C.active := false) let enable_module modules identifier = @@ -37,7 +39,9 @@ let enable_module modules identifier = String.sub identifier ~pos:1 ~len:(String.length identifier - 1) in List.iter modules ~f:(fun t -> - let (module C : Qsp_syntax.S.Analyzer) = Qsp_checks.Check.get_module t in + let (module C : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module t + in if String.equal C.identifier identifier then C.active := true) let speclist printer = @@ -74,7 +78,7 @@ let speclist printer = common_arguments @ windows_arguments let parse : - modules:Qsp_syntax.Catalog.ex list -> + modules:Qsp_syntax.Identifier.t list -> list_tests:(Format.formatter -> unit) -> string list * t = fun ~modules ~list_tests -> diff --git a/bin/args.mli b/bin/args.mli index a98b258..151a4ca 100644 --- a/bin/args.mli +++ b/bin/args.mli @@ -4,6 +4,6 @@ type t = { reset_line : bool; filters : filters } (** All the arguments given from the command line *) val parse : - modules:Qsp_syntax.Catalog.ex list -> + modules:Qsp_syntax.Identifier.t list -> list_tests:(Format.formatter -> unit) -> string list * t diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml index a8ee457..7ec3eff 100644 --- a/bin/qsp_parser.ml +++ b/bin/qsp_parser.ml @@ -14,20 +14,30 @@ let filter_report : Args.filters -> Report.t list -> Report.t -> Report.t list = type ctx = { error_nb : int; warn_nb : int; debug_nb : int; fatal_error : bool } +module type T = sig + include module type of Qsp_checks.Dynamics +end + +(** Witness used to extract the values in the module Qsp_checks.Dynamics during + the parsing. *) +let dynamic_context_id : Qsp_checks.Dynamics.context Type.Id.t = Type.Id.make () + (* List all the controls to apply *) let available_checks = [ - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Type_of); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dead_end); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Nested_strings); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Locations); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dup_test); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Write_only); + Qsp_syntax.Identifier.build ~context_id:dynamic_context_id + (module Qsp_checks.Dynamics); + Qsp_syntax.Identifier.build (module Qsp_checks.Type_of); + Qsp_syntax.Identifier.build (module Qsp_checks.Dead_end); + Qsp_syntax.Identifier.build (module Qsp_checks.Nested_strings); + Qsp_syntax.Identifier.build (module Qsp_checks.Locations); + Qsp_syntax.Identifier.build (module Qsp_checks.Dup_test); + Qsp_syntax.Identifier.build (module Qsp_checks.Write_only); ] -let pp_module formatter (module A : Qsp_syntax.S.Analyzer) = +let pp_module formatter (module A : Qsp_syntax.Analyzer.T) = Format.fprintf formatter "%s" A.identifier; Format.pp_print_tab formatter (); (match !A.active with @@ -41,8 +51,8 @@ let pp_module formatter (module A : Qsp_syntax.S.Analyzer) = let pp_modules formatter = let max_length = List.fold_left available_checks ~init:0 ~f:(fun l v -> - let (module A : Qsp_syntax.S.Analyzer) = - Qsp_checks.Check.get_module v + let (module A : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module v in max l (String.length A.identifier)) in @@ -61,7 +71,7 @@ let pp_modules formatter = Format.fprintf formatter "%a" (Format.pp_print_list (fun f v -> - let m = Qsp_checks.Check.get_module v in + let m = Qsp_syntax.Identifier.get_module v in pp_module f m) ~pp_sep:(fun f () -> Format.pp_force_newline f ())) available_checks; @@ -72,57 +82,117 @@ let pp_modules formatter = The expression is declared lazy in order to be sure to apply the filters from the command line before. *) -let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t = +let checkers : + (module Qsp_syntax.Analyzer.T + with type context = Qsp_checks.Check.result array) + Lazy.t = lazy (let module Check = Qsp_checks.Check.Make (struct let t = List.filter available_checks ~f:(fun v -> - let (module A : Qsp_syntax.S.Analyzer) = - Qsp_checks.Check.get_module v + let (module A : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module v in !A.active) |> Array.of_list end) in (module Check)) +let pp_report : + (Format.formatter -> 'a -> unit) -> + Qparser.Lexbuf.t -> + Format.formatter -> + 'a -> + unit = + fun pp lexbuf fmt e -> + let start_position, _ = Qparser.Lexbuf.positions lexbuf in + Format.fprintf fmt "Location@ %s@;@[%a@]@." start_position.Lexing.pos_fname pp + e + +let display_result : + ctx:ctx ref -> + Qparser.Lexbuf.t -> + Args.filters -> + (Report.t list, Report.t) result -> + unit = + fun ~ctx lexbuf filters result -> + match result with + | Error e -> + (* Syntax error, we haven’t been able to run the test *) + pp_report Report.pp lexbuf Format.std_formatter e; + ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true } + | Ok report -> ( + let report = + List.fold_left report ~init:[] ~f:(filter_report filters) + |> List.sort ~cmp:Report.compare + in + match report with + | [] -> () + | _ -> + (* Display the result *) + pp_report Report.pp_result lexbuf Format.std_formatter report; + + List.iter report ~f:(fun report -> + match report.Report.level with + | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb } + | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb } + | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb })) + (** Read the source file until getting a report (the whole location has been read properly), or until the first syntax error. The function update the context (list of errors) passed in arguments. *) -let parse_location : type context. +let parse_location : ctx:ctx ref -> - (module Qsp_syntax.S.Analyzer with type context = context) -> - context -> + (module Qsp_syntax.Analyzer.T + with type context = Qsp_checks.Check.result array) -> + Qsp_checks.Check.result array -> Qparser.Lexbuf.t -> Args.filters -> unit = fun ~ctx (module Check) context lexbuf filters -> let result = - Qparser.Analyzer.parse (module Check) lexbuf context - |> Result.map (fun f -> - List.fold_left f.Qparser.Analyzer.report ~init:[] - ~f:(filter_report filters) - |> List.sort ~cmp:Report.compare) + Qparser.Analyzer.parse + (module Check) + Qparser.Analyzer.Location lexbuf context in - match result with - | Ok [] -> () - | Ok report -> - (* Display the result *) - let start_position, _ = Qparser.Lexbuf.positions lexbuf in - Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@." - start_position.Lexing.pos_fname Report.pp_result report; - - List.iter report ~f:(fun report -> - match report.Report.level with - | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb } - | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb } - | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb }) - | Error e -> - (* Syntax error, we haven’t been able to run the test *) - let start_position, _ = Qparser.Lexbuf.positions lexbuf in - Format.fprintf Format.std_formatter "Location@ %s@;@[%a]@." - start_position.Lexing.pos_fname Report.pp e; - ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true } + + (* Also analyse eache dynamic string identified in the module *) + let result_with_dynamics = + Result.map + (fun r -> + match Qsp_checks.Check.get dynamic_context_id (Array.get context 0) with + | None -> r.Qparser.Analyzer.report + | Some dyn_context -> + let seq : Qsp_checks.Dynamics.text Seq.t = + Qsp_checks.Dynamics.dynamics_string dyn_context + in + Seq.fold_left + (fun r content -> + let text = content.Qsp_checks.Dynamics.content ^ "\n" in + + let lexing = + Sedlexing.Latin1.from_string text + |> Qparser.Lexbuf.from_lexbuf + ~position:(fst content.Qsp_checks.Dynamics.position) + in + + let dyn_report = + Qparser.Analyzer.parse + (module Check) + Qparser.Analyzer.Dynamic lexing context + in + match dyn_report with + | Error e -> + (* Syntax error are not blocking here, but are transformed + into check error *) + e :: r + | Ok dyn_ok_reports -> + dyn_ok_reports.Qparser.Analyzer.report @ r) + r.Qparser.Analyzer.report seq) + result + in + display_result ~ctx lexbuf filters result_with_dynamics let () = let file_names, parameters = @@ -140,10 +210,13 @@ let () = | ".qsrc" -> (* Deactivate the tests which only applies to a global file *) List.iter available_checks ~f:(fun t -> - let (module C : Qsp_syntax.S.Analyzer) = - Qsp_checks.Check.get_module t + let (module C : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module t in if C.is_global && !C.active then C.active := false); + + Qsp_checks.Dynamics.active := true; + (* The source file are in UTF-8, and we can use the file line number as we have only a single location. *) ( Sedlexing.Utf8.from_channel ic, diff --git a/dune-project b/dune-project index d89e83b..4646023 100644 --- a/dune-project +++ b/dune-project @@ -29,6 +29,7 @@ sedlex fmt ppx_deriving + tsort ) (tags (topics "to describe" your project))) diff --git a/lib/checks/check.ml b/lib/checks/check.ml index 6169bb1..597bc0a 100644 --- a/lib/checks/check.ml +++ b/lib/checks/check.ml @@ -1,5 +1,4 @@ module S = Qsp_syntax.S -module C = Qsp_syntax.Catalog (** The the Id module, wrap a value in an existencial type with a witness associate with. *) @@ -11,10 +10,13 @@ let get : type a. a Type.Id.t -> result -> a option = | Some Type.Equal -> Some value | None -> None -type t = Qsp_syntax.Catalog.ex +let set : type a. a Type.Id.t -> result -> a -> result option = + fun typeid (R { witness; _ }) value -> + match Type.Id.provably_equal typeid witness with + | Some Type.Equal -> Some (R { witness; value }) + | None -> None -let get_module : t -> (module S.Analyzer) = - fun (E { module_; _ }) -> (module_ :> (module S.Analyzer)) +type t = Qsp_syntax.Identifier.t module type App = sig val t : t array @@ -42,23 +44,85 @@ module Make (A : App) = struct let description = "Internal module" let is_global = false let active = ref false + let depends = [] (* This modules depends of nothing *) + + type ex = Qsp_syntax.Identifier.t type context = result Array.t (** We associate each context from the differents test in an array. The context for this module is a sort of context of contexts *) + (* Initialize the modules to check here, at the module level *) + let checks = + (* Collect all the dependencies and build the execution order *) + let graph : ex list = + let rec build_deps l acc = + List.fold_left + (l : ex list) + ~init:acc + ~f:(fun + acc (Qsp_syntax.Identifier.E { module_ = (module S); _ } as ex) -> + let acc' = ex :: acc in + + build_deps S.depends acc') + in + build_deps (Array.to_list A.t) [] + in + + (* Convert the dependenciees using the module identifier only, the + Tsort.sort function use structural equality comparaison function which + does not wok with the module embeded in first class module. *) + let graph_name = + List.map graph + ~f:(fun (Qsp_syntax.Identifier.E { module_ = (module S); _ }) -> + let deps' = + List.map + ~f:(fun (Qsp_syntax.Identifier.E { module_ = (module S); _ }) -> + S.identifier) + S.depends + in + (S.identifier, deps')) + in + match Tsort.sort graph_name with + | Tsort.Sorted sorted_graph -> + (* From the identifier, extract the associated check *) + let _ = + List.map sorted_graph ~f:(fun name -> + List.find_map graph + ~f:(fun + (Qsp_syntax.Identifier.E { module_ = (module S); _ } as + check) + -> + match String.equal name S.identifier with + | false -> None + | true -> Some check) + |> Option.get) + (* It’s ok to use unchecked option.get here, because the list was + created from the same source just before *) + in + + Array.of_list graph + | Tsort.ErrorCycle _ -> + (* This is very unlikely to happen, as it would reflect an error in + the compilation units order *) + raise Not_found + (** Initialize each test, and keep the result in the context. *) let initialize : unit -> context = fun () -> - Array.map A.t ~f:(fun (C.E { module_ = (module S); context; _ }) -> + Array.map checks + ~f:(fun (Qsp_syntax.Identifier.E { module_ = (module S); context; _ }) -> let value = S.initialize () in R { value; witness = context }) let finalize : result Array.t -> (string * Qsp_syntax.Report.t) list = fun context_array -> let _, report = - Array.fold_left A.t ~init:(0, []) - ~f:(fun (i, acc) (C.E { module_ = (module S); context; _ }) -> + Array.fold_left checks ~init:(0, []) + ~f:(fun + (i, acc) + (Qsp_syntax.Identifier.E { module_ = (module S); context; _ }) + -> let result = Array.get context_array i in let local_context = Option.get (get context result) in let reports = S.finalize local_context in @@ -67,111 +131,195 @@ module Make (A : App) = struct report (* Global variable for the whole module *) - let len = Array.length A.t + let len = Array.length checks module Expression : S.Expression with type t' = result array = struct type t = result array type t' = result array - let literal : S.pos -> t Qsp_syntax.T.literal list -> t = - fun pos values -> - Array.mapi A.t - ~f:(fun i (C.E { module_ = (module S); expr_witness; _ }) -> - (* Map every values to the Checker *) - let values' = - List.map values - ~f: - (Qsp_syntax.T.map_litteral ~f:(fun expr -> - Option.get (get expr_witness (Array.get expr i)))) - in - let value = S.Expression.literal pos values' in - R { value; witness = expr_witness }) - - let integer : S.pos -> string -> t = - fun pos value -> - Array.map A.t ~f:(fun (C.E { module_ = (module S); expr_witness; _ }) -> - let value = S.Expression.integer pos value in - R { value; witness = expr_witness }) + let build_ctx : result option array -> Qsp_syntax.S.extract_context = + fun results -> + { + f = + (fun id -> + Array.find_map results ~f:(function + | Some result -> get id result + | None -> None)); + } + + let literal : + ctx:Qsp_syntax.S.extract_context -> + S.pos -> + t Qsp_syntax.T.literal list -> + t = + fun ~ctx pos values -> + ignore ctx; + let results = Array.make len None in + (* Create the new array, filled with None at the begining. + + Then populate the array in place in order to read the previous values + if requested *) + (* Extract the result with the given ID from the array *) + let ctx = build_ctx results in + let () = + Array.mapi_inplace results ~f:(fun i _ -> + let (Qsp_syntax.Identifier.E + { module_ = (module S); expr_witness; _ }) = + Array.get checks i + in + (* Map every values to the Checker *) + let values' = + List.map values + ~f: + (Qsp_syntax.T.map_litteral ~f:(fun expr -> + Option.get (get expr_witness (Array.get expr i)))) + in + let value = S.Expression.literal ~ctx pos values' in + Some (R { value; witness = expr_witness })) + in + Array.map results ~f:Option.get - (** Unary operator like [-123] or [+'Text']*) - let uoperator : S.pos -> Qsp_syntax.T.uoperator -> t -> t = - fun pos op values -> - (* Evaluate the nested expression *) - let results = values in + let integer : ctx:Qsp_syntax.S.extract_context -> S.pos -> string -> t = + fun ~ctx pos value -> + ignore ctx; + let results = Array.make len None in + let ctx = build_ctx results in - (* Now evaluate the remaining expression. + let () = + Array.mapi_inplace results ~f:(fun i _ -> + let (Qsp_syntax.Identifier.E + { module_ = (module S); expr_witness; _ }) = + Array.get checks i + in + let value = S.Expression.integer ~ctx pos value in + Some (R { value; witness = expr_witness })) + in + Array.map results ~f:Option.get - Traverse both the module the apply, and the matching expression already - evaluated. + (** Unary operator like [-123] or [+'Text']*) + let uoperator : + ctx:Qsp_syntax.S.extract_context -> + S.pos -> + Qsp_syntax.T.uoperator -> + t -> + t = + fun ~ctx pos op values -> + ignore ctx; + let results = Array.make len None in + let ctx = build_ctx results in - It’s easer to use [map] and declare [report] as reference instead of - [fold_left2] and accumulate the report inside the closure, because I - don’t manage the order of the results. - *) - let results = - Array.map2 A.t results - ~f:(fun (C.E { module_ = (module S); expr_witness; _ }) value -> + (* Evaluate the nested expression *) + let () = + Array.mapi_inplace results ~f:(fun i _ -> + let (Qsp_syntax.Identifier.E + { module_ = (module S); expr_witness; _ }) = + Array.get checks i + in + let value = Array.get values i in match get expr_witness value with | None -> failwith "Does not match" | Some value -> (* Evaluate the single expression *) - let value = S.Expression.uoperator pos op value in - R { witness = expr_witness; value }) + let value = S.Expression.uoperator ~ctx pos op value in + Some (R { witness = expr_witness; value })) in - results + Array.map results ~f:Option.get (** Basically the same as uoperator, but operate over two operands instead of a single one. *) - let boperator : S.pos -> Qsp_syntax.T.boperator -> t -> t -> t = - fun pos op expr1 expr2 -> - Array.init len ~f:(fun i -> - let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in - match - ( get expr_witness (Array.get expr1 i), - get expr_witness (Array.get expr2 i) ) - with - | Some value_1, Some value_2 -> - let value = S.Expression.boperator pos op value_1 value_2 in - R { witness = expr_witness; value } - | _ -> failwith "Does not match") + let boperator : + ctx:Qsp_syntax.S.extract_context -> + S.pos -> + Qsp_syntax.T.boperator -> + t -> + t -> + t = + fun ~ctx pos op expr1 expr2 -> + ignore ctx; + let results = Array.make len None in + let ctx = build_ctx results in + let () = + Array.mapi_inplace results ~f:(fun i _ -> + let (E { module_ = (module S); expr_witness; _ }) = + Array.get checks i + in + match + ( get expr_witness (Array.get expr1 i), + get expr_witness (Array.get expr2 i) ) + with + | Some value_1, Some value_2 -> + let value = + S.Expression.boperator ~ctx pos op value_1 value_2 + in + Some (R { witness = expr_witness; value }) + | _ -> failwith "Does not match") + in + Array.map results ~f:Option.get (** Call a function. The functions list is hardcoded in lib/lexer.mll *) - let function_ : S.pos -> Qsp_syntax.T.function_ -> t list -> t = - fun pos func args -> - Array.init len ~f:(fun i -> - let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in - (* Extract the arguments for each module *) - let args_i = List.rev (Helper.expr_i args expr_witness i).values in - let value = S.Expression.function_ pos func args_i in - R { witness = expr_witness; value }) - - let ident : (S.pos, t) S.variable -> t = - fun { pos : S.pos; name : string; index : t option } -> - Array.init len ~f:(fun i -> - let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in - - match index with - | None -> - (* Easest case, just return the plain ident *) - let value = S.Expression.ident { pos; name; index = None } in - R { witness = expr_witness; value } - | Some t -> ( - match get expr_witness (Array.get t i) with - | None -> failwith "Does not match" - | Some value_1 -> - let value = - S.Expression.ident { pos; name; index = Some value_1 } - in - R { witness = expr_witness; value })) + let function_ : + ctx:Qsp_syntax.S.extract_context -> + S.pos -> + Qsp_syntax.T.function_ -> + t list -> + t = + fun ~ctx pos func args -> + ignore ctx; + let results = Array.make len None in + let ctx = build_ctx results in + let () = + Array.mapi_inplace results ~f:(fun i _ -> + let (E { module_ = (module S); expr_witness; _ }) = + Array.get checks i + in + (* Extract the arguments for each module *) + let args_i = List.rev (Helper.expr_i args expr_witness i).values in + let value = S.Expression.function_ ~ctx pos func args_i in + Some (R { witness = expr_witness; value })) + in + Array.map results ~f:Option.get + + let ident : ctx:Qsp_syntax.S.extract_context -> (S.pos, t) S.variable -> t = + fun ~ctx { pos : S.pos; name : string; index : t option } -> + ignore ctx; + let results = Array.make len None in + let ctx = build_ctx results in + let () = + Array.mapi_inplace results ~f:(fun i _ -> + let (E { module_ = (module S); expr_witness; _ }) = + Array.get checks i + in + + match index with + | None -> + (* Easest case, just return the plain ident *) + let value = + S.Expression.ident ~ctx { pos; name; index = None } + in + Some (R { witness = expr_witness; value }) + | Some t -> ( + match get expr_witness (Array.get t i) with + | None -> failwith "Does not match" + | Some value_1 -> + let value = + S.Expression.ident ~ctx + { pos; name; index = Some value_1 } + in + Some (R { witness = expr_witness; value }))) + in + Array.map results ~f:Option.get (** Convert each internal represention for the expression into its external representation *) let v : t -> t' = fun t -> let result = - Array.map2 A.t t + Array.map2 checks t ~f:(fun - (C.E { module_ = (module S); expr_witness; expr'; _ }) result -> + (Qsp_syntax.Identifier.E + { module_ = (module S); expr_witness; expr'; _ }) + result + -> match get expr_witness result with | None -> failwith "Does not match" | Some value -> @@ -191,21 +339,30 @@ module Make (A : App) = struct let location : S.pos -> string -> t = fun pos label -> - Array.map A.t ~f:(fun (C.E { module_ = (module S); instr_witness; _ }) -> + Array.map checks + ~f:(fun + (Qsp_syntax.Identifier.E { module_ = (module S); instr_witness; _ }) + -> let value = S.Instruction.location pos label in R { value; witness = instr_witness }) let comment : S.pos -> t = fun pos -> - Array.map A.t ~f:(fun (C.E { module_ = (module S); instr_witness; _ }) -> + Array.map checks + ~f:(fun + (Qsp_syntax.Identifier.E { module_ = (module S); instr_witness; _ }) + -> let value = S.Instruction.comment pos in R { value; witness = instr_witness }) let expression : expression -> t = fun expr -> - Array.map2 A.t expr + Array.map2 checks expr ~f:(fun - (C.E { module_ = (module S); instr_witness; expr'; _ }) result -> + (Qsp_syntax.Identifier.E + { module_ = (module S); instr_witness; expr'; _ }) + result + -> match get expr' result with | None -> failwith "Does not match" | Some value -> @@ -219,7 +376,7 @@ module Make (A : App) = struct actually the list of each expression in the differents modules. *) Array.init len ~f:(fun i -> let (E { module_ = (module S); expr'; instr_witness; _ }) = - Array.get A.t i + Array.get checks i in let values = List.rev (Helper.expr_i args expr' i).values in @@ -231,7 +388,7 @@ module Make (A : App) = struct fun pos ~label instructions -> Array.init len ~f:(fun i -> let (E { module_ = (module S); instr_witness; expr'; _ }) = - Array.get A.t i + Array.get checks i in let values = List.rev (Helper.expr_i instructions instr_witness i).values @@ -254,7 +411,7 @@ module Make (A : App) = struct fun pos { pos = var_pos; name; index } op expression -> Array.init len ~f:(fun i -> let (E { module_ = (module A); instr_witness; expr'; _ }) = - Array.get A.t i + Array.get checks i in let index_i = @@ -303,7 +460,7 @@ module Make (A : App) = struct in Array.init len ~f:(fun i -> let (E { module_ = (module A); instr_witness; expr'; _ }) = - Array.get A.t i + Array.get checks i in let clause = rebuild_clause i instr_witness expr' clause @@ -324,9 +481,12 @@ module Make (A : App) = struct let v : t -> t' = fun t -> let result = - Array.map2 A.t t + Array.map2 checks t ~f:(fun - (C.E { module_ = (module S); instr_witness; instr'; _ }) result -> + (Qsp_syntax.Identifier.E + { module_ = (module S); instr_witness; instr'; _ }) + result + -> match get instr_witness result with | None -> failwith "Does not match" | Some value -> @@ -358,7 +518,7 @@ module Make (A : App) = struct context; _; }) = - Array.get A.t i + Array.get checks i in let local_context = @@ -377,7 +537,7 @@ module Make (A : App) = struct let () = Array.iteri args ~f:(fun i result -> let (E { module_ = (module A); location_witness; _ }) = - Array.get A.t i + Array.get checks i in match get location_witness result with | None -> failwith "Does not match" diff --git a/lib/checks/check.mli b/lib/checks/check.mli index 8502753..34d953f 100644 --- a/lib/checks/check.mli +++ b/lib/checks/check.mli @@ -13,17 +13,20 @@ end) ]} *) -val get_module : Qsp_syntax.Catalog.ex -> (module Qsp_syntax.S.Analyzer) - type result val get : 'a Type.Id.t -> result -> 'a option (** The method [get] can be used to get the internal value for one of the checker used. *) +val set : 'a Type.Id.t -> result -> 'a -> result option + module Make (A : sig - val t : Qsp_syntax.Catalog.ex array + val t : Qsp_syntax.Identifier.t array end) : sig - include Qsp_syntax.S.Analyzer with type Location.t = result array + include + Qsp_syntax.Analyzer.T + with type Location.t = result array + and type context = result array end [@@warning "-67"] diff --git a/lib/checks/compose.ml b/lib/checks/compose.ml deleted file mode 100644 index 4517755..0000000 --- a/lib/checks/compose.ml +++ /dev/null @@ -1,127 +0,0 @@ -(** Build a module with the result from another one module *) - -open StdLabels -module S = Qsp_syntax.S -module T = Qsp_syntax.T - -(** Make a module lazy *) -module Lazier (E : S.Expression) : - S.Expression with type t' = E.t' Lazy.t and type t = E.t Lazy.t = struct - type t = E.t Lazy.t - type t' = E.t' Lazy.t - - let v : E.t Lazy.t -> E.t' Lazy.t = Lazy.map E.v - let integer : S.pos -> string -> t = fun pos i -> lazy (E.integer pos i) - - let ident : (S.pos, t) S.variable -> t = - fun { pos; name : string; index : t option } -> - lazy (E.ident { pos; name; index = Option.map Lazy.force index }) - - let literal : S.pos -> t T.literal list -> t = - fun pos litts -> - lazy - (let e_litts = List.map litts ~f:(T.map_litteral ~f:Lazy.force) in - E.literal pos e_litts) - - let function_ : S.pos -> T.function_ -> t list -> t = - fun pos f e -> - lazy - (let e' = List.map ~f:Lazy.force e in - E.function_ pos f e') - - let uoperator : S.pos -> T.uoperator -> t -> t = - fun pos op t -> - let t' = lazy (E.uoperator pos op (Lazy.force t)) in - t' - - let boperator : S.pos -> T.boperator -> t -> t -> t = - fun pos op t1 t2 -> - let t' = lazy (E.boperator pos op (Lazy.force t1) (Lazy.force t2)) in - t' -end - -(** Build an expression module with the result from another expression. The - signature of the fuctions is a bit different, as they all receive the - result from the previous evaluated element in argument. *) -module Expression (E : S.Expression) = struct - module type SIG = sig - type t - type t' - - (* Override the type [t] in the definition of all the functions. The - signatures differs a bit from the standard signature as they get the - result from E.t in last argument *) - - val ident : (S.pos, E.t' Lazy.t * t) S.variable -> E.t' Lazy.t -> t - val integer : S.pos -> string -> E.t' Lazy.t -> t - val literal : S.pos -> (E.t' Lazy.t * t) T.literal list -> E.t' Lazy.t -> t - - val function_ : - S.pos -> T.function_ -> (E.t' Lazy.t * t) list -> E.t' Lazy.t -> t - - val uoperator : S.pos -> T.uoperator -> E.t' Lazy.t * t -> E.t' Lazy.t -> t - - val boperator : - S.pos -> - T.boperator -> - E.t' Lazy.t * t -> - E.t' Lazy.t * t -> - E.t' Lazy.t -> - t - - val v : E.t' Lazy.t * t -> t' - (** Convert from the internal representation to the external one. *) - end - - (* Create a lazy version of the module *) - module E = Lazier (E) - - module Make (M : SIG) : S.Expression with type t' = M.t' = struct - type t = E.t * M.t - type t' = M.t' - - let v' : E.t -> E.t' = E.v - let v : t -> t' = fun (type_of, v) -> M.v (v' type_of, v) - - let ident : (S.pos, t) S.variable -> t = - fun { pos; name : string; index : t option } -> - let t' = E.ident { pos; name; index = Option.map fst index } in - let index' = Option.map (fun (e, m) -> (v' e, m)) index in - (t', M.ident { pos; name; index = index' } (v' t')) - - let integer : S.pos -> string -> t = - fun pos i -> - let t' = E.integer pos i in - (t', M.integer pos i (v' t')) - - let literal : S.pos -> t T.literal list -> t = - fun pos litts -> - let litts' = - List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (v' e, m))) - in - - let t' = - let e_litts = List.map litts ~f:(T.map_litteral ~f:fst) in - E.literal pos e_litts - in - (t', M.literal pos litts' (v' t')) - - let function_ : S.pos -> T.function_ -> t list -> t = - fun pos f expressions -> - let e = List.map ~f:fst expressions - and expressions' = List.map ~f:(fun (e, m) -> (v' e, m)) expressions in - - let t' = E.function_ pos f e in - (t', M.function_ pos f expressions' (v' t')) - - let uoperator : S.pos -> T.uoperator -> t -> t = - fun pos op (t, expr) -> - let t' = E.uoperator pos op t in - (t', M.uoperator pos op (v' t, expr) (v' t')) - - let boperator : S.pos -> T.boperator -> t -> t -> t = - fun pos op (t1, expr1) (t2, expr2) -> - let t' = E.boperator pos op t1 t2 in - (t', M.boperator pos op (v' t1, expr1) (v' t2, expr2) (v' t')) - end -end diff --git a/lib/checks/dead_end.ml b/lib/checks/dead_end.ml index 629a966..dd3e945 100644 --- a/lib/checks/dead_end.ml +++ b/lib/checks/dead_end.ml @@ -7,7 +7,9 @@ let identifier = "dead_end" let description = "Check for dead end in the code" let is_global = false let active = ref false +let depends = [] +type ex = Qsp_syntax.Identifier.t type context = unit let initialize = Fun.id @@ -40,10 +42,8 @@ module Instruction = struct (** For each instruction, return thoses two informations : - - the intruction contains at [gt] - - the last instruction is a [gt] - - *) + - the intruction contains at [gt] + - the last instruction is a [gt] *) let v : t -> t' = fun t -> t let default = @@ -73,7 +73,8 @@ module Instruction = struct (** Raw expression *) let expression : Expression.t' -> t = fun _ -> default - (** The content of a block is very linear, I only need to check the last element *) + (** The content of a block is very linear, I only need to check the last + element *) let check_block : S.pos -> t list -> t = fun pos instructions -> let last_element = diff --git a/lib/checks/dead_end.mli b/lib/checks/dead_end.mli index d8fe7d6..73ec86a 100644 --- a/lib/checks/dead_end.mli +++ b/lib/checks/dead_end.mli @@ -1,6 +1,5 @@ -(** Checker looking for the dead ends in the source. +(** Checker looking for the dead ends in the source. - A dead end is a state where the user does not have any action. - *) + A dead end is a state where the user does not have any action. *) -include Qsp_syntax.S.Analyzer +include Qsp_syntax.Analyzer.T with type ex = Qsp_syntax.Identifier.t diff --git a/lib/checks/default.ml b/lib/checks/default.ml index a2b53f6..0ec1084 100644 --- a/lib/checks/default.ml +++ b/lib/checks/default.ml @@ -1,45 +1,138 @@ -(** Default implementation which does nothing. +(** Default implementation which does nothing. -This module is expected to be used when you only need to implement an analyze -over a limited part of the whole syntax. *) + This module is expected to be used when you only need to implement an + analyze over a limited part of the whole syntax. *) +open StdLabels module S = Qsp_syntax.S module T = Qsp_syntax.T module Report = Qsp_syntax.Report -module type T = sig +module Expression (T' : sig type t val default : t -end - -module Expression (T' : T) = struct - (** - Describe a variable, using the name in capitalized text, and an optionnal +end) = +struct + (** Describe a variable, using the name in capitalized text, and an optionnal index. - If missing, the index should be considered as [0]. - *) + If missing, the index should be considered as [0]. *) type t' = T'.t - let ident : (S.pos, T'.t) S.variable -> T'.t = fun _ -> T'.default + let ident : + ctx:Qsp_syntax.S.extract_context -> (S.pos, T'.t) S.variable -> T'.t = + fun ~ctx _ -> + ignore ctx; + T'.default (* Basic values, text, number… *) - let integer : S.pos -> string -> T'.t = fun _ _ -> T'.default - let literal : S.pos -> T'.t T.literal list -> T'.t = fun _ _ -> T'.default + let integer : ctx:Qsp_syntax.S.extract_context -> S.pos -> string -> T'.t = + fun ~ctx _ _ -> + ignore ctx; + T'.default + + let literal : + ctx:Qsp_syntax.S.extract_context -> S.pos -> T'.t T.literal list -> T'.t = + fun ~ctx _ _ -> + ignore ctx; + T'.default (** Call a function. The functions list is hardcoded in lib/lexer.mll *) - let function_ : S.pos -> T.function_ -> T'.t list -> T'.t = - fun _ _ _ -> T'.default + let function_ : + ctx:Qsp_syntax.S.extract_context -> + S.pos -> + T.function_ -> + T'.t list -> + T'.t = + fun ~ctx _ _ _ -> + ignore ctx; + T'.default (** Unary operator like [-123] or [+'Text']*) - let uoperator : S.pos -> T.uoperator -> T'.t -> T'.t = fun _ _ _ -> T'.default + let uoperator : + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.uoperator -> T'.t -> T'.t = + fun ~ctx _ _ _ -> + ignore ctx; + T'.default (** Binary operator, for a comparaison, or an operation *) - let boperator : S.pos -> T.boperator -> T'.t -> T'.t -> T'.t = - fun _ _ _ _ -> T'.default + let boperator : + ctx:Qsp_syntax.S.extract_context -> + S.pos -> + T.boperator -> + T'.t -> + T'.t -> + T'.t = + fun ~ctx _ _ _ _ -> + ignore ctx; + T'.default +end + +module Instruction (Expression : sig + type t' +end) (T : sig + type t + + val default : t + val fold : t Seq.t -> t +end) = +struct + let call : S.pos -> Qsp_syntax.T.keywords -> Expression.t' list -> T.t = + fun _ _ _ -> T.default + + let location : S.pos -> string -> T.t = + fun position name -> + ignore position; + ignore name; + T.default + + let comment : S.pos -> T.t = + fun position -> + ignore position; + T.default + + let expression : Expression.t' -> T.t = + fun expr -> + ignore expr; + T.default + + let map_clause : (Expression.t', T.t) S.clause -> T.t Seq.t = + fun (_, _, els) -> List.to_seq els + + let if_ : + S.pos -> + (Expression.t', T.t) S.clause -> + elifs:(Expression.t', T.t) S.clause list -> + else_:(S.pos * T.t list) option -> + T.t = + fun pos clause ~elifs ~else_ -> + ignore pos; + + let seq = List.to_seq (clause :: elifs) |> Seq.flat_map map_clause in + + let seq = + match else_ with + | None -> seq + | Some (_, ts) -> Seq.append seq (List.to_seq ts) + in + T.fold seq + + let act : S.pos -> label:Expression.t' -> T.t list -> T.t = + fun pos ~label instructions -> + ignore pos; + ignore label; + T.fold (List.to_seq instructions) + + let assign : + S.pos -> + (S.pos, Expression.t') S.variable -> + Qsp_syntax.T.assignation_operator -> + Expression.t' -> + T.t = + fun _ _ _ _ -> T.default end diff --git a/lib/checks/dune b/lib/checks/dune index d7db2f3..75b311b 100644 --- a/lib/checks/dune +++ b/lib/checks/dune @@ -1,9 +1,12 @@ (library (name qsp_checks) (libraries + tsort qsp_syntax ) (preprocess (pps - ppx_deriving.show ppx_deriving.enum + ppx_deriving.show + ppx_deriving.enum + ppx_deriving.ord ppx_deriving.eq ))) diff --git a/lib/checks/dup_test.ml b/lib/checks/dup_test.ml index 9ffe7c5..4de9a4d 100644 --- a/lib/checks/dup_test.ml +++ b/lib/checks/dup_test.ml @@ -1,9 +1,7 @@ (** This module check for duplicated tests in the source.contents - - This in intended to identify the copy/paste errors, where one location - check for the same arguments twice or more. - *) + This in intended to identify the copy/paste errors, where one location check + for the same arguments twice or more. *) open StdLabels module S = Qsp_syntax.S @@ -15,7 +13,9 @@ let identifier = "duplicate_test" let description = "Check for duplicate tests" let is_global = false let active = ref true +let depends = [] +type ex = Qsp_syntax.Identifier.t type context = unit let initialize = Fun.id @@ -23,8 +23,8 @@ let finalize () = [] module Expression = Tree.Expression -(** Build a Hashtbl over the expression, ignoring the location in the - expression *) +(** Build a Hashtbl over the expression, ignoring the location in the expression +*) module Table = Hashtbl.Make (struct type t = Expression.t' @@ -37,23 +37,33 @@ module Instruction = struct predicates : (Expression.t' * S.pos) list; duplicates : (Expression.t' * S.pos list) list; } - (** Keep the list of all the predicates and their position in a block, and - the list of all the identified duplicated values. *) + (** Keep the list of all the predicates and their position in a block, and the + list of all the identified duplicated values. *) type t = state type t' = state - let v : t -> t' = fun t -> t let default = { predicates = []; duplicates = [] } - (** Label for a loop *) - let location : S.pos -> string -> t = fun _ _ -> default + include + Default.Instruction + (Expression) + (struct + type nonrec t = t - (** Comment *) - let comment : S.pos -> t = fun _ -> default + let default = default - (** Raw expression *) - let expression : Expression.t' -> t = fun _ -> default + let fold sequence = + Seq.fold_left + (fun state ex -> + { + predicates = []; + duplicates = List.rev_append ex.duplicates state.duplicates; + }) + default sequence + end) + + let v : t -> t' = fun t -> t let check_duplicates : (Expression.t' * S.pos) list -> (Expression.t' * S.pos list) list = @@ -74,10 +84,9 @@ module Instruction = struct | other -> Some (hd, other))) |> List.of_seq - (** Evaluate a clause. - This function does two things : - - report all errors from the bottom to top - - add the clause in the actual level *) + (** Evaluate a clause. This function does two things : + - report all errors from the bottom to top + - add the clause in the actual level *) let predicate_of_clause : ?pos:S.pos -> t -> (Expression.t', t) S.clause -> t = fun ?pos t (pos2, predicate, blocks) -> @@ -118,27 +127,6 @@ module Instruction = struct state with duplicates = check_duplicates state.predicates @ state.duplicates; } - - let act : S.pos -> label:Expression.t' -> t list -> t = - fun _pos ~label expressions -> - ignore label; - (* Collect all the elements reported from bottom to up. *) - List.fold_left ~init:default expressions ~f:(fun state ex -> - { - predicates = []; - duplicates = List.rev_append ex.duplicates state.duplicates; - }) - - let assign : - S.pos -> - (S.pos, Expression.t') S.variable -> - T.assignation_operator -> - Expression.t' -> - t = - fun _ _ _ _ -> default - - let call : S.pos -> T.keywords -> Expression.t' list -> t = - fun _ _ _ -> default end module Location = struct diff --git a/lib/checks/dup_test.mli b/lib/checks/dup_test.mli index 6446c67..a771a46 100644 --- a/lib/checks/dup_test.mli +++ b/lib/checks/dup_test.mli @@ -1 +1 @@ -include Qsp_syntax.S.Analyzer +include Qsp_syntax.Analyzer.T with type ex = Qsp_syntax.Identifier.t diff --git a/lib/checks/dynamics.ml b/lib/checks/dynamics.ml new file mode 100644 index 0000000..f88550b --- /dev/null +++ b/lib/checks/dynamics.ml @@ -0,0 +1,269 @@ +open StdLabels +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report + +let identifier = "dynamics" +let description = "Report all dynamics string in the module" +let is_global = true +let active = ref false +let depends = [] + +type ex = Qsp_syntax.Identifier.t +type text = { content : string; position : S.pos } [@@deriving eq, ord] + +module StringSet = Set.Make (struct + type t = text [@@deriving ord] +end) + +type context = StringSet.t ref + +let initialize () = ref StringSet.empty + +module Expression = struct + (** Elements wich can be given to dynamic. + + For Text, I do not evaluate text containing expression. This need to be a + plain text. + + In the case of variable, indexes will probably not work if they include + function or complex expression *) + type t = None | Text of text | Variable of (unit, t) S.variable + [@@deriving eq, ord] + + (** Remove all the locations inside a variable in order to be able to compare + two of them at differents locations *) + let rec anonymize_variable : (unit, t) S.variable -> (unit, t) S.variable = + fun ({ index; _ } as variable) -> + let index = + Option.map + (function + | None -> None + | Text { content; _ } -> + let position = (Lexing.dummy_pos, Lexing.dummy_pos) in + Text { content; position } + | Variable var -> Variable (anonymize_variable var)) + index + in + { variable with index } + + include Default.Expression (struct + type nonrec t = t + + let default = None + end) + + let v : t -> t' = Fun.id + + (** Only keep the raw strings *) + let literal : + ctx:Qsp_syntax.S.extract_context -> S.pos -> t T.literal list -> t = + fun ~ctx position content -> + ignore ctx; + ignore position; + match content with + | [ T.Text content ] -> Text { content; position } + | _ -> ( + (* Here I analyse if the expression is a string or + numeric. In case of numeric, it is possible to replace it with a + default value *) + let buffer = Buffer.create 16 in + let res = + List.fold_left ~init:`Ok content ~f:(fun state literal -> + match (state, literal) with + | `None, _ -> `None + | `Ok, T.Expression None -> `None + | `Ok, T.Expression (Text content) -> + Buffer.add_string buffer content.content; + `Ok + | `Ok, T.Text content -> + Buffer.add_string buffer content; + `Ok + | `Ok, T.Expression (Variable { name; _ }) -> + let res = + if Char.equal '$' name.[0] then `None + else ( + Buffer.add_char buffer '0'; + `Ok) + in + res) + in + match res with + | `Ok -> Text { content = Buffer.contents buffer; position } + | _ -> None) + + (** Consider the integer as text. This is easier for evaluating the indices in + the arrays (it use the same code as text indices), and will report bad use + of dynamics. *) + let integer : ctx:Qsp_syntax.S.extract_context -> S.pos -> string -> t = + fun ~ctx position content -> + ignore ctx; + Text { content; position } + + (** If the identifier uses any unmanaged expression in the indices, ignore it. + *) + let ident : ctx:Qsp_syntax.S.extract_context -> (S.pos, t) S.variable -> t = + fun ~ctx ({ index; _ } as ident) -> + ignore ctx; + let is_valid = + Option.fold ~none:true index ~some:(fun opt -> + match opt with None -> false | _ -> true) + in + match is_valid with + | false -> None + | true -> Variable (anonymize_variable { ident with pos = () }) +end + +module Instruction = struct + (** This map holds the values for each variable seen in the code *) + module StringMap = struct + include Hashtbl.Make (struct + type t = (unit, Expression.t) S.variable [@@deriving eq] + + let hash = Hashtbl.hash + end) + + (** Recursive search in the table *) + let rec_find : + Expression.t' t -> (unit, Expression.t) S.variable -> StringSet.t = + fun table key -> + let rec _f init key = + let values = find_all table key in + List.fold_left values ~init ~f:(fun acc value -> + match value with + | Expression.None -> acc + | Expression.Text text -> StringSet.add text acc + | Expression.Variable variable -> _f acc variable) + in + _f StringSet.empty key + end + + module VariableSet = Set.Make (struct + type t = (unit, Expression.t) S.variable [@@deriving ord] + end) + + type context = { + catalog : Expression.t' StringMap.t; + texts : StringSet.t; + blacklist : VariableSet.t; + variable_called : VariableSet.t; + } + (** Keep the content of each string in order to parse it later *) + + (** This module do two things : keep a track of the raw strings in the + location, and identify the calls to the function dynamic. + + The dynamic parameter are reported as is, and are evaluated only at the + end of the module. *) + + type t = context -> context + type t' = t + + let v = Fun.id + + include + Default.Instruction + (Expression) + (struct + type nonrec t = t + + let fold : t Seq.t -> t = + fun seq init_context -> + let result = + Seq.fold_left + (fun context (instr : t) -> instr context) + init_context seq + in + result + + let default context = context + end) + + (** Keep the track of dynamic instructions *) + let call : S.pos -> T.keywords -> Expression.t' list -> t = + fun position keyword arg context -> + ignore position; + ignore arg; + match keyword with + | T.Dynamic -> ( + match arg with + | [ Expression.Text text ] -> + let texts = StringSet.add text context.texts in + + { context with texts } + | [ Expression.Variable var ] -> + let variable_called = VariableSet.add var context.variable_called in + { context with variable_called } + | _ -> context) + | _ -> context + + let assign : + S.pos -> + (S.pos, Expression.t') S.variable -> + T.assignation_operator -> + Expression.t' -> + t = + fun pos variable op expression context -> + ignore pos; + let variable' = Expression.anonymize_variable { variable with pos = () } in + let is_blacklisted = VariableSet.mem variable' context.blacklist in + let is_string = variable.name.[0] = '$' in + match (op, expression, is_blacklisted, is_string) with + | T.Eq', Expression.Text content, false, true + when not (String.equal content.content "") -> + StringMap.add context.catalog variable' expression; + context + | T.Eq', Expression.Variable _, false, _ -> + StringMap.add context.catalog variable' expression; + context + | _ -> + (* If the assignation is not direct, we **remove** all the bindings + from the catalog. *) + StringMap.find_all context.catalog variable' + |> List.iter ~f:(fun _ -> StringMap.remove context.catalog variable'); + + (* We also black list this variable and prevent further additions *) + let blacklist = VariableSet.add variable' context.blacklist in + { context with blacklist } +end + +module Location = struct + type t = unit + type instruction = Instruction.t' + + let location : context -> S.pos -> instruction list -> t = + fun context pos instr -> + ignore pos; + let catalog = Instruction.StringMap.create 16 in + let init = + Instruction. + { + catalog; + texts = !context; + blacklist = VariableSet.empty; + variable_called = VariableSet.empty; + } + in + let res = List.fold_left instr ~init ~f:(fun acc instr -> instr acc) in + + (* Now, for each dynamics calling a variable, looks in the catalog if we + can find the associated string *) + let texts = + Instruction.VariableSet.fold + (fun variable acc -> + let indirects = Instruction.StringMap.rec_find res.catalog variable in + + StringSet.union acc indirects) + res.variable_called res.texts + in + context := texts + + let v : t -> Report.t list = fun _ -> [] +end + +let finalize context = + ignore context; + [] + +let dynamics_string : context -> text Seq.t = + fun context -> StringSet.to_seq !context diff --git a/lib/checks/dynamics.mli b/lib/checks/dynamics.mli new file mode 100644 index 0000000..588a05e --- /dev/null +++ b/lib/checks/dynamics.mli @@ -0,0 +1,5 @@ +include Qsp_syntax.Analyzer.T with type ex = Qsp_syntax.Identifier.t + +type text = { content : string; position : Qsp_syntax.S.pos } + +val dynamics_string : context -> text Seq.t diff --git a/lib/checks/get_type.ml b/lib/checks/get_type.ml index 04bf780..00270c2 100644 --- a/lib/checks/get_type.ml +++ b/lib/checks/get_type.ml @@ -17,116 +17,183 @@ type type_of = (** String containing a numeric value *) [@@deriving show { with_path = false }, eq] -type t = Variable of type_of | Raw of type_of [@@deriving show, eq] -type t' = t - -let v = Fun.id -let get_type : t -> type_of = function Raw r -> r | Variable r -> r - -let map : t -> type_of -> t = - fun t type_of -> - match t with Raw _ -> Raw type_of | Variable _ -> Variable type_of - -let get_nature : t -> t -> type_of -> t = - fun t1 t2 type_of -> - match (t1, t2) with - | Variable _, _ -> Variable type_of - | _, Variable _ -> Variable type_of - | Raw _, Raw _ -> Raw type_of - -let integer : S.pos -> string -> t = fun _ _ -> Raw Integer - -let ident : (S.pos, 'any) S.variable -> t = - fun var -> - match var.name.[0] with '$' -> Variable String | _ -> Variable Integer - -let literal : S.pos -> t T.literal list -> t = - fun pos values -> - ignore pos; - let init = None in - let typed = - List.fold_left values ~init ~f:(fun state -> function - | T.Text t -> ( - (* Tranform the type, but keep the information is it’s a raw data +module Expression = struct + type t = Variable of type_of | Raw of type_of [@@deriving show, eq] + type t' = t + + let v = Fun.id + let get_type : t -> type_of = function Raw r -> r | Variable r -> r + + let map : t -> type_of -> t = + fun t type_of -> + match t with Raw _ -> Raw type_of | Variable _ -> Variable type_of + + let get_nature : t -> t -> type_of -> t = + fun t1 t2 type_of -> + match (t1, t2) with + | Variable _, _ -> Variable type_of + | _, Variable _ -> Variable type_of + | Raw _, Raw _ -> Raw type_of + + let integer : ctx:Qsp_syntax.S.extract_context -> S.pos -> string -> t = + fun ~ctx _ _ -> + ignore ctx; + Raw Integer + + let ident : ctx:Qsp_syntax.S.extract_context -> (S.pos, 'any) S.variable -> t + = + fun ~ctx var -> + ignore ctx; + match var.name.[0] with '$' -> Variable String | _ -> Variable Integer + + let literal : + ctx:Qsp_syntax.S.extract_context -> S.pos -> t T.literal list -> t = + fun ~ctx pos values -> + ignore ctx; + ignore pos; + let init = None in + let typed = + List.fold_left values ~init ~f:(fun state -> function + | T.Text t -> ( + (* Tranform the type, but keep the information is it’s a raw data or a variable one *) - let nature = Option.value ~default:(Raw Integer) state in - match (Option.map get_type state, int_of_string_opt t) with - | None, Some _ - | Some Integer, Some _ - | Some NumericString, Some _ - | Some Bool, Some _ -> - Some (map nature NumericString) - | _, _ -> - if String.equal "" t then - (* If the text is empty, ignore it *) - state - else Some (map nature String)) - | T.Expression t -> ( - let nature = Option.value ~default:(Raw Integer) state in - match (Option.map get_type state, get_type t) with - | None, Integer | Some NumericString, Integer -> - Some (get_nature nature t NumericString) - | _ -> Some (map nature String))) - in - let result = Option.value ~default:(Raw String) typed in - result - -let uoperator : S.pos -> T.uoperator -> t -> t = - fun pos operator t -> - ignore pos; - match operator with Add -> t | Neg | No -> Raw Integer - -let boperator : S.pos -> T.boperator -> t -> t -> t = - fun pos operator t1 t2 -> - ignore pos; - match operator with - | T.Plus -> ( - match (get_type t1, get_type t2) with - | Integer, Integer -> get_nature t1 t2 Integer - | String, _ -> get_nature t1 t2 String - | _, String -> get_nature t1 t2 String - | (_ as t), Bool -> get_nature t1 t2 t - | Bool, (_ as t) -> get_nature t1 t2 t - | (_ as t), NumericString -> get_nature t1 t2 t - | NumericString, (_ as t) -> get_nature t1 t2 t) - | T.Eq | T.Neq -> get_nature t1 t2 Bool - | T.Mod | T.Minus | T.Product | T.Div -> get_nature t1 t2 Integer - | T.And | T.Or -> get_nature t1 t2 Bool - | Lt | Gte | Lte | Gt -> get_nature t1 t2 Bool - -let function_ : S.pos -> T.function_ -> t list -> t = - fun pos function_ params -> - ignore pos; - match function_ with - | Dyneval | Dyneval' -> Variable NumericString - | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Getobj | Instr | Isplay -> - Variable Integer - | Desc' | Getobj' -> Variable String - | Func | Func' -> Variable NumericString - | Iif | Iif' -> ( match params with _ :: t :: _ -> t | _ -> Raw Bool) - | Input | Input' -> Variable NumericString - | Isnum -> Raw Bool - | Lcase | Lcase' | Ucase | Ucase' -> Raw String - | Len -> Raw Integer - | Loc -> Variable Bool - | Max | Max' | Min | Min' -> ( - match params with - | [] -> Raw Bool - | Raw String :: [] | Variable String :: [] -> Variable NumericString - | hd :: _ -> hd) - | Mid | Mid' -> Variable String - | Msecscount -> Raw Integer - | Rand -> Raw Integer - | Replace -> Variable String - | Replace' -> Variable String - | Rgb -> Raw Integer - | Rnd -> Raw Integer - | Selact -> Variable String - | Str | Str' -> Raw String - | Strcomp -> Raw Bool - | Strfind -> Variable String - | Strfind' -> Variable String - | Strpos -> Raw Integer - | Trim -> Variable String - | Trim' -> Variable String - | Val -> Raw Integer + let nature = Option.value ~default:(Raw Integer) state in + match (Option.map get_type state, int_of_string_opt t) with + | None, Some _ + | Some Integer, Some _ + | Some NumericString, Some _ + | Some Bool, Some _ -> + Some (map nature NumericString) + | _, _ -> + if String.equal "" t then + (* If the text is empty, ignore it *) + state + else Some (map nature String)) + | T.Expression t -> ( + let nature = Option.value ~default:(Raw Integer) state in + match (Option.map get_type state, get_type t) with + | None, Integer | Some NumericString, Integer -> + Some (get_nature nature t NumericString) + | _ -> Some (map nature String))) + in + let result = Option.value ~default:(Raw String) typed in + result + + let uoperator : + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.uoperator -> t -> t = + fun ~ctx pos operator t -> + ignore ctx; + ignore pos; + match operator with Add -> t | Neg | No -> Raw Integer + + let boperator : + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.boperator -> t -> t -> t = + fun ~ctx pos operator t1 t2 -> + ignore ctx; + ignore pos; + match operator with + | T.Plus -> ( + match (get_type t1, get_type t2) with + | Integer, Integer -> get_nature t1 t2 Integer + | String, _ -> get_nature t1 t2 String + | _, String -> get_nature t1 t2 String + | (_ as t), Bool -> get_nature t1 t2 t + | Bool, (_ as t) -> get_nature t1 t2 t + | (_ as t), NumericString -> get_nature t1 t2 t + | NumericString, (_ as t) -> get_nature t1 t2 t) + | T.Eq | T.Neq -> get_nature t1 t2 Bool + | T.Mod | T.Minus | T.Product | T.Div -> get_nature t1 t2 Integer + | T.And | T.Or -> get_nature t1 t2 Bool + | Lt | Gte | Lte | Gt -> get_nature t1 t2 Bool + + let function_ : + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.function_ -> t list -> t = + fun ~ctx pos function_ params -> + ignore ctx; + ignore pos; + match function_ with + | Dyneval | Dyneval' -> Variable NumericString + | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Getobj | Instr | Isplay -> + Variable Integer + | Desc' | Getobj' -> Variable String + | Func | Func' -> Variable NumericString + | Iif | Iif' -> ( match params with _ :: t :: _ -> t | _ -> Raw Bool) + | Input | Input' -> Variable NumericString + | Isnum -> Raw Bool + | Lcase | Lcase' | Ucase | Ucase' -> Raw String + | Len -> Variable Integer + | Loc -> Variable Bool + | Max | Max' | Min | Min' -> ( + match params with + | [] -> Raw Bool + | Raw String :: [] | Variable String :: [] -> Variable NumericString + | hd :: _ -> hd) + | Mid | Mid' -> Variable String + | Msecscount -> Variable Integer + | Rand -> Variable Integer + | Replace -> Variable String + | Replace' -> Variable String + | Rgb -> Variable Integer + | Rnd -> Variable Integer + | Selact -> Variable String + | Str | Str' -> Raw String + | Strcomp -> Raw Bool + | Strfind -> Variable String + | Strfind' -> Variable String + | Strpos -> Variable Integer + | Trim -> Variable String + | Trim' -> Variable String + | Val -> Variable Integer +end + +module A = struct + let identifier = "get_types" + let description = "Identify the type for an expression" + let is_global = true + let active = ref false + let depends = [] + + type ex = Qsp_syntax.Identifier.t + type context = unit + + let initialize () = () + + module Expression = Expression + + module Instruction = struct + type t = unit + type t' = unit + + include + Default.Instruction + (Expression) + (struct + type t = unit + + let default = () + let fold seq = Seq.iter (fun _ -> ()) seq + end) + + let v = Fun.id + end + + module Location = struct + type t = unit + type instruction = Instruction.t' + + let location : context -> S.pos -> instruction list -> t = + fun context pos instr -> + ignore context; + ignore pos; + List.iter instr ~f:(fun _ -> ()) + + let v : t -> Report.t list = fun _ -> [] + end + + let finalize context = + ignore context; + [] +end + +let expression_id = Type.Id.make () +let ex = Qsp_syntax.Identifier.build ~expression_id (module A) diff --git a/lib/checks/get_type.mli b/lib/checks/get_type.mli new file mode 100644 index 0000000..476059b --- /dev/null +++ b/lib/checks/get_type.mli @@ -0,0 +1,25 @@ +type type_of = + | Integer (** A numeric value *) + | Bool (** A boolean, not a real type *) + | String (** String value *) + | NumericString (** String containing a numeric value *) +[@@deriving show, eq] + +module Expression : sig + type t = Variable of type_of | Raw of type_of [@@deriving show, eq] + type t' = t + + include Qsp_syntax.S.Expression with type t := t and type t' := t' + + val ident : + ctx:Qsp_syntax.S.extract_context -> + (Qsp_syntax.S.pos, 'any) Qsp_syntax.S.variable -> + t + + val get_type : t -> type_of +end + +val expression_id : Expression.t Type.Id.t +(** Type identifier for the expression in this module *) + +val ex : Qsp_syntax.Identifier.t diff --git a/lib/checks/locations.ml b/lib/checks/locations.ml index 8ee6ffa..3a5ddf5 100644 --- a/lib/checks/locations.ml +++ b/lib/checks/locations.ml @@ -20,6 +20,9 @@ let identifier = "locations" let description = "Ensure every call points to an existing location" let is_global = true let active = ref true +let depends = [] + +type ex = Qsp_syntax.Identifier.t type t = { locations : LocationSet.t; @@ -74,7 +77,7 @@ let registerLocation : string -> t -> t = { calls; locations } (** The module Expression is pretty simple, we are only interrested by the - strings ( because only the first argument of [gt …] is read ). + strings ( because only the first argument of [gt …] is read ). If the string is too much complex, we just ignore it. *) module Expression = struct @@ -89,8 +92,11 @@ module Expression = struct let v : t -> t' = Fun.id (* Extract the litteral if this is a simple text *) - let literal : S.pos -> t' T.literal list -> t' = - fun _ ll -> match ll with Text lit :: [] -> Some lit | _ -> None + let literal : + ctx:Qsp_syntax.S.extract_context -> S.pos -> t' T.literal list -> t' = + fun ~ctx _ ll -> + ignore ctx; + match ll with Text lit :: [] -> Some lit | _ -> None end module Instruction = struct @@ -99,6 +105,18 @@ module Instruction = struct let v : t -> t' = Fun.id + include + Default.Instruction + (Expression) + (struct + type nonrec t = t + + let default = Fun.id + + let fold : t Seq.t -> t = + fun sequence t -> Seq.fold_left (fun acc t -> t acc) t sequence + end) + (** Keep a track of every gt or gs instruction *) let call : S.pos -> T.keywords -> Expression.t' list -> t = fun pos fn args t -> @@ -106,43 +124,6 @@ module Instruction = struct | T.Goto, Some dest :: _ -> registerCall pos dest t | T.Gosub, Some dest :: _ -> registerCall pos dest t | _ -> t - - let location : S.pos -> string -> t = fun _ _ -> Fun.id - let comment : S.pos -> t = fun _ -> Fun.id - let expression : Expression.t' -> t = fun _ -> Fun.id - - let if_ : - S.pos -> - (Expression.t', t) S.clause -> - elifs:(Expression.t', t) S.clause list -> - else_:(S.pos * t list) option -> - t = - fun _ clause ~elifs ~else_ t -> - let traverse_clause t clause = - let _, _, block = clause in - List.fold_left block ~init:t ~f:(fun t instruction -> instruction t) - in - - let t = traverse_clause t clause in - let t = List.fold_left ~init:t ~f:traverse_clause elifs in - match else_ with - | None -> t - | Some (_, instructions) -> - List.fold_left instructions ~init:t ~f:(fun t instruction -> - instruction t) - - let act : S.pos -> label:Expression.t' -> t list -> t = - fun _ ~label instructions t -> - ignore label; - List.fold_left instructions ~init:t ~f:(fun t instruction -> instruction t) - - let assign : - S.pos -> - (S.pos, Expression.t') S.variable -> - T.assignation_operator -> - Expression.t' -> - t = - fun _ _ _ _ -> Fun.id end module Location = struct diff --git a/lib/checks/nested_strings.ml b/lib/checks/nested_strings.ml index e4ffb68..d4a7947 100644 --- a/lib/checks/nested_strings.ml +++ b/lib/checks/nested_strings.ml @@ -7,82 +7,77 @@ let identifier = "escaped_string" let description = "Check for unnecessary use of expression encoded in string" let is_global = false let active = ref true +let depends = [ Get_type.ex ] +type ex = Qsp_syntax.Identifier.t type context = unit let initialize = Fun.id let finalize () = [] -module TypeBuilder = Compose.Expression (Get_type) - -module Expression = TypeBuilder.Make (struct - type t = Report.t list +module Expression = struct + type t = { type_of : Get_type.Expression.t; report : Report.t list } type t' = Report.t list - let v : Get_type.t Lazy.t * t -> t' = snd + let v : t -> t' = fun t -> t.report (** Identify the expressions reprented as string. That’s here that the report - are added. + are added. All the rest of the module only push thoses warning to the top level. *) let literal : - S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t - = - fun pos content _type_of -> + ctx:Qsp_syntax.S.extract_context -> S.pos -> t T.literal list -> t = + fun ~ctx pos content -> + let type_of = Option.get (ctx.f Get_type.expression_id) in match content with - | [ T.Expression (t', _); T.Text "" ] -> ( - match Get_type.get_type (Lazy.force t') with - | Get_type.Integer -> [] + | [ T.Expression t; T.Text "" ] -> ( + match Get_type.Expression.get_type t.type_of with + | Get_type.Integer -> { type_of; report = [] } | _ -> let msg = Report.debug pos "This expression can be simplified" in - [ msg ]) - | _ -> [] + { type_of; report = [ msg ] }) + | _ -> { type_of; report = [] } - let ident : - (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t = - fun variable _type_of -> - match variable.index with None -> [] | Some (_, t) -> t + let ident : ctx:Qsp_syntax.S.extract_context -> (S.pos, t) S.variable -> t = + fun ~ctx variable -> + let type_of = Option.get (ctx.f Get_type.expression_id) in + match variable.index with None -> { type_of; report = [] } | Some t -> t - let integer : S.pos -> string -> Get_type.t Lazy.t -> t = - fun pos t _type_of -> + let integer : ctx:Qsp_syntax.S.extract_context -> S.pos -> string -> t = + fun ~ctx pos t -> ignore pos; ignore t; - [] + let type_of = Option.get (ctx.f Get_type.expression_id) in + { type_of; report = [] } let function_ : - S.pos -> - T.function_ -> - (Get_type.t Lazy.t * t) list -> - Get_type.t Lazy.t -> - t = - fun pos f expressions _type_of -> + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.function_ -> t list -> t = + fun ~ctx pos f expressions -> + let type_of = Option.get (ctx.f Get_type.expression_id) in ignore pos; ignore f; let exprs = List.fold_left ~init:[] expressions ~f:(fun acc el -> - List.rev_append (snd el) acc) + List.rev_append el.report acc) in - exprs + { type_of; report = exprs } let uoperator : - S.pos -> T.uoperator -> Get_type.t Lazy.t * t -> Get_type.t Lazy.t -> t = - fun pos op r _type_of -> + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.uoperator -> t -> t = + fun ~ctx pos op r -> + let type_of = Option.get (ctx.f Get_type.expression_id) in ignore op; ignore pos; - snd r + { r with type_of } let boperator : - S.pos -> - T.boperator -> - Get_type.t Lazy.t * t -> - Get_type.t Lazy.t * t -> - Get_type.t Lazy.t -> - t = - fun pos op (_, r1) (_, r2) _type_of -> + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.boperator -> t -> t -> t = + fun ~ctx pos op r1 r2 -> + let type_of = Option.get (ctx.f Get_type.expression_id) in ignore pos; ignore op; - r1 @ r2 -end) + { type_of; report = r1.report @ r2.report } +end module Instruction : S.Instruction with type t' = Report.t list and type expression = Expression.t' = diff --git a/lib/checks/nested_strings.mli b/lib/checks/nested_strings.mli index 1ef2e33..01e373a 100644 --- a/lib/checks/nested_strings.mli +++ b/lib/checks/nested_strings.mli @@ -1,3 +1,3 @@ -include Qsp_syntax.S.Analyzer +include Qsp_syntax.Analyzer.T with type ex = Qsp_syntax.Identifier.t (** The module [Nested_strings] report errors for each unnecessary raw string encoded inside a string expression *) diff --git a/lib/checks/type_of.ml b/lib/checks/type_of.ml index 70ae324..243c8b3 100644 --- a/lib/checks/type_of.ml +++ b/lib/checks/type_of.ml @@ -12,16 +12,19 @@ type context = unit let initialize = Fun.id let finalize () = [] +let depends = [ Get_type.ex ] + +type ex = Qsp_syntax.Identifier.t module Helper = struct - type argument_repr = { pos : S.pos; t : Get_type.t } + type argument_repr = { pos : S.pos; t : Get_type.Expression.t } module DynType = struct - type nonrec t = Get_type.t -> Get_type.t + type nonrec t = Get_type.Expression.t -> Get_type.Expression.t (** Dynamic type is a type unknown during the code. - For example, the equality operator accept either Integer or String, but - we expect that both sides of the equality uses the same type.*) + For example, the equality operator accept either Integer or String, but + we expect that both sides of the equality uses the same type.*) (** Build a new dynamic type *) let t : unit -> t = @@ -35,11 +38,11 @@ module Helper = struct | Some t -> t end - (** Declare an argument for a function. + (** Declare an argument for a function. - - Either we already know the type and we just have to compare. - - Either the type shall constrained by another one - - Or we have a variable number of arguments. *) + - Either we already know the type and we just have to compare. + - Either the type shall constrained by another one + - Or we have a variable number of arguments. *) type argument = | Fixed of Get_type.type_of | Dynamic of DynType.t @@ -143,37 +146,35 @@ module Helper = struct msg :: report end -module TypeBuilder = Compose.Expression (Get_type) - -type t' = { result : Get_type.t Lazy.t; pos : S.pos } +type t' = { result : Get_type.Expression.t; pos : S.pos } -let arg_of_repr : Get_type.t Lazy.t -> S.pos -> Helper.argument_repr = - fun type_of pos -> { pos; t = Lazy.force type_of } +let arg_of_repr : Get_type.Expression.t -> S.pos -> Helper.argument_repr = + fun type_of pos -> { pos; t = type_of } -module TypedExpression = struct +module Expression = struct type nonrec t' = t' * Report.t list - type state = { pos : S.pos } + type state = { pos : S.pos; type_of : Get_type.Expression.t } type t = state * Report.t list - let v : Get_type.t Lazy.t * t -> t' = - fun (type_of, (t, r)) -> ({ result = type_of; pos = t.pos }, r) + let v : t -> t' = fun (t, r) -> ({ result = t.type_of; pos = t.pos }, r) (** The variable has type string when starting with a '$' *) - let ident : - (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t = - fun var _type_of -> + let ident : ctx:Qsp_syntax.S.extract_context -> (S.pos, t) S.variable -> t = + fun ~ctx var -> (* Extract the error from the index *) let report = match var.index with | None -> [] | Some (_, expr) -> - let _, r = expr in + let r = expr in r in - ({ pos = var.pos }, report) + let type_of = Option.get (ctx.f Get_type.expression_id) in + ({ pos = var.pos; type_of }, report) - let integer : S.pos -> string -> Get_type.t Lazy.t -> t = - fun pos value _type_of -> + let integer : ctx:Qsp_syntax.S.extract_context -> S.pos -> string -> t = + fun ~ctx pos value -> + let type_of = Option.get (ctx.f Get_type.expression_id) in let int_value = int_of_string_opt value in let report = @@ -183,42 +184,36 @@ module TypedExpression = struct | None -> Report.error pos "Invalid integer value" :: [] in - ({ pos }, report) + ({ pos; type_of }, report) let literal : - S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t - = - fun pos values type_of -> - ignore type_of; + ctx:Qsp_syntax.S.extract_context -> S.pos -> t T.literal list -> t = + fun ~ctx pos values -> + let type_of = Option.get (ctx.f Get_type.expression_id) in let init = [] in let report = List.fold_left values ~init ~f:(fun report -> function | T.Text _ -> report - | T.Expression (_, t) -> + | T.Expression t -> let report = List.rev_append (snd t) report in report) in - ({ pos }, report) + ({ pos; type_of }, report) let function_ : - S.pos -> - T.function_ -> - (Get_type.t Lazy.t * t) list -> - Get_type.t Lazy.t -> - t = - fun pos function_ params _type_of -> + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.function_ -> t list -> t = + fun ~ctx pos function_ params -> + let type_of = Option.get (ctx.f Get_type.expression_id) in (* Accumulate the expressions and get the results, the report is given in the differents arguments, and we build a list with the type of the parameters. *) let types, report = - List.fold_left params ~init:([], []) - ~f:(fun (types, report) (type_of, param) -> - ignore type_of; + List.fold_left params ~init:([], []) ~f:(fun (types, report) param -> let t, r = param in - let arg = arg_of_repr type_of t.pos in + let arg = arg_of_repr t.type_of t.pos in (arg :: types, r @ report)) in - let types = List.rev types and default = { pos } in + let types = List.rev types and default = { pos; type_of } in match function_ with | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Getobj | Instr @@ -231,7 +226,7 @@ module TypedExpression = struct let expected = Helper.[ Fixed Bool; Dynamic d; Dynamic d ] in let report = Helper.compare_args pos expected types report in (* Extract the type for the expression *) - ({ pos }, report) + ({ pos; type_of }, report) | Input | Input' -> (* Input should check the result if the variable is a num and raise a message in this case.*) @@ -259,7 +254,7 @@ module TypedExpression = struct (* All the arguments must have the same type *) let expected = Helper.[ Variable (Dynamic d) ] in let report = Helper.compare_args pos expected types report in - ({ pos }, report) + ({ pos; type_of }, report) | Mid | Mid' -> let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in let report = Helper.compare_args pos expected types report in @@ -294,29 +289,25 @@ module TypedExpression = struct (** Unary operator like [-123] or [+'Text']*) let uoperator : - S.pos -> T.uoperator -> Get_type.t Lazy.t * t -> Get_type.t Lazy.t -> t = - fun pos operator t1 type_of -> - ignore type_of; - let type_of, (t, report) = t1 in + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.uoperator -> t -> t = + fun ~ctx pos operator t1 -> + let t, report = t1 in match operator with | Add -> (t, report) | Neg | No -> - let types = [ arg_of_repr type_of t.pos ] in + let types = [ arg_of_repr t.type_of t.pos ] in let expected = Helper.[ Fixed Integer ] in let report = Helper.compare_args pos expected types report in - ({ pos }, report) + let type_of = Option.get (ctx.f Get_type.expression_id) in + ({ pos; type_of }, report) let boperator : - S.pos -> - T.boperator -> - Get_type.t Lazy.t * t -> - Get_type.t Lazy.t * t -> - Get_type.t Lazy.t -> - t = - fun pos operator (type_1, t1) (type_2, t2) type_of -> - ignore type_of; + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.boperator -> t -> t -> t = + fun ~ctx pos operator t1 t2 -> let t1, report1 = t1 in let t2, report2 = t2 in + let type_1 = t1.type_of and type_2 = t2.type_of in + let type_of = Option.get (ctx.f Get_type.expression_id) in let report = report1 @ report2 in @@ -329,7 +320,7 @@ module TypedExpression = struct When concatenating, it’s allowed to add an integer and a number. *) - ({ pos }, report) + ({ pos; type_of }, report) | T.Eq | T.Neq | Lt | Gte | Lte | Gt -> (* If the expression is '' or 0, we accept the comparaison as if instead of raising a warning *) @@ -347,26 +338,24 @@ module TypedExpression = struct report | report -> report in - ({ pos }, report) + ({ pos; type_of }, report) | T.Mod | T.Minus | T.Product | T.Div -> (* Operation over number *) let expected = Helper.[ Fixed Integer; Fixed Integer ] in let report = Helper.compare_args pos expected types report in - ({ pos }, report) + ({ pos; type_of }, report) | T.And | T.Or -> (* Operation over booleans *) let expected = Helper.[ Fixed Bool; Fixed Bool ] in let report = Helper.compare_args pos expected types report in - ({ pos }, report) + ({ pos; type_of }, report) end -module Expression = TypeBuilder.Make (TypedExpression) - module Instruction = struct type t = Report.t list type t' = Report.t list - let v : t -> t' = fun local_report -> local_report + let v : t -> t' = Fun.id type expression = Expression.t' @@ -446,17 +435,21 @@ module Instruction = struct let report = List.rev_append report' report in - match (op, Get_type.get_type (Lazy.force right_expression.result)) with + match (op, Get_type.Expression.get_type right_expression.result) with | T.Eq', Get_type.Integer -> (* Assigning an intger is allowed in a string variable, but raise a warning. *) - let var_type = Lazy.from_val (Get_type.ident variable) in + let var_type = + Get_type.Expression.ident ~ctx:{ f = (fun _ -> None) } variable + in let op1 = arg_of_repr var_type variable.pos in let expected = Helper.[ Fixed Integer ] in Helper.compare_args ~strict:true ~level:Report.Warn pos expected [ op1 ] report | _, _ -> ( - let var_type = Lazy.from_val (Get_type.ident variable) in + let var_type = + Get_type.Expression.ident ~ctx:{ f = (fun _ -> None) } variable + in let op1 = arg_of_repr var_type variable.pos in let op2 = arg_of_repr right_expression.result right_expression.pos in diff --git a/lib/checks/type_of.mli b/lib/checks/type_of.mli index de0f8f9..f2be559 100644 --- a/lib/checks/type_of.mli +++ b/lib/checks/type_of.mli @@ -1,7 +1,7 @@ -include Qsp_syntax.S.Analyzer +include Qsp_syntax.Analyzer.T with type ex = Qsp_syntax.Identifier.t (** The module [type_of] populate the report with differents inconsistency - errors in the types. + errors in the types. - - Assigning a [string] value in an [integer] variable - - Comparing a [string] with an [integer] - - Giving the wrong type in the argument for a function and so one. *) + - Assigning a [string] value in an [integer] variable + - Comparing a [string] with an [integer] + - Giving the wrong type in the argument for a function and so one. *) diff --git a/lib/checks/write_only.ml b/lib/checks/write_only.ml index 8363703..2d78b59 100644 --- a/lib/checks/write_only.ml +++ b/lib/checks/write_only.ml @@ -15,17 +15,12 @@ let description = "Check variables never read" let active = ref false let is_global = true +let depends = [] -module Key = struct - type t = string +type ex = Qsp_syntax.Identifier.t - let equal = String.equal - let hash = Hashtbl.hash - let compare = String.compare -end - -module StringMap = Hashtbl.Make (Key) -module Set = Set.Make (Key) +module StringMap = Hashtbl.Make (String) +module Set = Set.Make (String) type data = { write : bool; read : bool; position : S.pos list } type context = (string * data) StringMap.t @@ -84,13 +79,16 @@ module Expression = struct let default _ map = ignore map end) - let ident : (S.pos, t) S.variable -> t = - fun variable filename map -> + let ident : ctx:Qsp_syntax.S.extract_context -> (S.pos, t) S.variable -> t = + fun ~ctx variable filename map -> + ignore ctx; (* Update the map and set the read flag *) set_readed variable.pos variable.name filename map - let literal : S.pos -> t T.literal list -> t = - fun pos l filename map -> + let literal : + ctx:Qsp_syntax.S.extract_context -> S.pos -> t T.literal list -> t = + fun ~ctx pos l filename map -> + ignore ctx; List.iter l ~f:(function | T.Text t -> set_readed pos ~update_only:true (String.uppercase_ascii t) filename @@ -99,13 +97,22 @@ module Expression = struct (* When the string contains an expression evaluate it *) exprs filename map) - let function_ : S.pos -> T.function_ -> t list -> t = - fun _ _ exprs filename map -> List.iter ~f:(fun v -> v filename map) exprs + let function_ : + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.function_ -> t list -> t = + fun ~ctx _ _ exprs filename map -> + ignore ctx; + List.iter ~f:(fun v -> v filename map) exprs - let uoperator : S.pos -> T.uoperator -> t -> t = fun _ _ t map -> t map + let uoperator : + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.uoperator -> t -> t = + fun ~ctx _ _ t map -> + ignore ctx; + t map - let boperator : S.pos -> T.boperator -> t -> t -> t = - fun _ _ t1 t2 filename map -> + let boperator : + ctx:Qsp_syntax.S.extract_context -> S.pos -> T.boperator -> t -> t -> t = + fun ~ctx _ _ t1 t2 filename map -> + ignore ctx; t1 filename map; t2 filename map end diff --git a/lib/qparser/analyzer.ml b/lib/qparser/analyzer.ml index ca2b54f..fc0ed6d 100644 --- a/lib/qparser/analyzer.ml +++ b/lib/qparser/analyzer.ml @@ -1,28 +1,44 @@ type 'a result = { content : 'a; report : Qsp_syntax.Report.t list } +type lexer = Location | Dynamic -(** - Run the QSP parser and apply the analyzer over it. +let get_lexer : + Lexbuf.t -> + lexer -> + unit -> + Tokens.token * Lexing.position * Lexing.position = + fun l -> function + | Location -> Lexbuf.tokenize Lexer.main l + | Dynamic -> Lexbuf.tokenize Lexer.dynamics l + +(** Run the QSP parser and apply the analyzer over it. - See [syntax/S] - *) -let rec parse : - type a context. - (module Qsp_syntax.S.Analyzer + See [syntax/S] *) +let rec parse : type a context. + (module Qsp_syntax.Analyzer.T with type Location.t = a and type context = context) -> + lexer -> Lexbuf.t -> context -> (a result, Qsp_syntax.Report.t) Result.t = - fun (module S : Qsp_syntax.S.Analyzer + fun (module S : Qsp_syntax.Analyzer.T with type Location.t = a and type context = context) -> let module Parser = Parser.Make (S) in let module IncrementalParser = Interpreter.Interpreter (Parser.MenhirInterpreter) in - fun l context -> - let lexer = Lexbuf.tokenize Lexer.main l in + fun lexer_type l context -> + let get_parser : + lexer -> + Lexing.position -> + (context -> a) Parser.MenhirInterpreter.checkpoint = function + | Location -> Parser.Incremental.main + | Dynamic -> Parser.Incremental.dynamics + in + + let lexer = get_lexer l lexer_type in - let init = Parser.Incremental.main (fst (Lexbuf.positions l)) in + let init = (get_parser lexer_type) (fst (Lexbuf.positions l)) in (* Firslty, check if we are able to read the whole syntax from the source *) let evaluation = @@ -59,7 +75,7 @@ let rec parse : application attempt to start from a clean state in the next location, but may fail to detect the correct position. If so, we just start again until we hook the next location *) - parse (module S) l context + parse (module S) lexer_type l context | Error e, _ -> let message = match e.IncrementalParser.code with diff --git a/lib/qparser/analyzer.mli b/lib/qparser/analyzer.mli index 949db16..6e2f752 100644 --- a/lib/qparser/analyzer.mli +++ b/lib/qparser/analyzer.mli @@ -1,13 +1,15 @@ type 'a result = { content : 'a; report : Qsp_syntax.Report.t list } +type lexer = Location | Dynamic val parse : - (module Qsp_syntax.S.Analyzer + (module Qsp_syntax.Analyzer.T with type Location.t = 'a and type context = 'context) -> + lexer -> Lexbuf.t -> 'context -> ('a result, Qsp_syntax.Report.t) Result.t -(** Read the source and build a analyzis over it. +(** Read the source and build a analyzis over it. -This method make the link between the source file and how to read it -(encoding…) and the AST we want to build. *) + This method make the link between the source file and how to read it + (encoding…) and the AST we want to build. *) diff --git a/lib/qparser/expression_parser.messages b/lib/qparser/expression_parser.messages index b708d36..22ffd7d 100644 --- a/lib/qparser/expression_parser.messages +++ b/lib/qparser/expression_parser.messages @@ -1,3 +1,4 @@ +main: LOCATION_START EOL INTEGER SET main: LOCATION_START EOL IDENT SET Unexpected expression here. @@ -45,10 +46,6 @@ main: STAR Missing location name -main: LOCATION_START EOL INTEGER SET - - Unexpected expression here. - main: LOCATION_START EOL IF IDENT COLUMN EOL ELIF INTEGER SET The `ELIF` expression does not end properly. A `:` is expected before any instruction. @@ -114,3 +111,12 @@ main: LOCATION_START EOL IDENT STAR STAR main: LOCATION_START EOL IDENT MINUS STAR Unknown operator. Did you write '+ =' instead of '+=' ? + +dynamics: IDENT R_PAREN +dynamics: TEXT_MARKER ENTER_EMBED FUNCTION_NOARGS TEXT_MARKER + + Unbalanced paren + +dynamics: IDENT PLUS FUNCTION_NOARGS TEXT_MARKER + + Missing operator before text diff --git a/lib/qparser/lexbuf.ml b/lib/qparser/lexbuf.ml index afc3bac..9ba7938 100644 --- a/lib/qparser/lexbuf.ml +++ b/lib/qparser/lexbuf.ml @@ -41,6 +41,7 @@ let pp_state format = function let state : t -> state option = fun t -> Stack.top_opt t.state let enter_state : t -> state -> unit = fun t state -> Stack.push state t.state let leave_state : t -> unit = fun t -> ignore @@ Stack.pop_opt t.state +let clear_state : t -> unit = fun t -> Stack.clear t.state let buffer : t -> Sedlexing.lexbuf = fun t -> t.buffer let start : t -> unit = @@ -62,8 +63,10 @@ let positions : t -> Lexing.position * Lexing.position = let content : t -> string = fun t -> Sedlexing.Utf8.lexeme t.buffer -let from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t = - fun ?(reset_line = true) t -> +let from_lexbuf : + ?position:Lexing.position -> ?reset_line:bool -> Sedlexing.lexbuf -> t = + fun ?position ?(reset_line = true) t -> + Option.iter (Sedlexing.set_position t) position; { buffer = t; start_p = None; @@ -90,6 +93,7 @@ let tokenize : (t -> 'a) -> t -> unit -> 'a * Lexing.position * Lexing.position let default, curr_p = positions t in let start_p = Option.value ~default t.start_p in + t.recovering <- false; t.start_p <- None; (token, start_p, curr_p) diff --git a/lib/qparser/lexbuf.mli b/lib/qparser/lexbuf.mli index 4283db1..8beb9da 100644 --- a/lib/qparser/lexbuf.mli +++ b/lib/qparser/lexbuf.mli @@ -3,8 +3,11 @@ type t (** The state of the buffer *) -val from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t -(** Create a new buffer *) +val from_lexbuf : + ?position:Lexing.position -> ?reset_line:bool -> Sedlexing.lexbuf -> t +(** Create a new buffer. + + If a position is given, start from this position in the file. *) val start : t -> unit (** Intialize a new run. *) @@ -13,11 +16,10 @@ val buffer : t -> Sedlexing.lexbuf (** Extract the sedlex buffer. Required in each rule. *) val positions : t -> Lexing.position * Lexing.position -(** Extract the starting and ending position for the matched token. +(** Extract the starting and ending position for the matched token. - This function is used outside of the parser, in order to get the position - of the latest token in the case of an error. - *) + This function is used outside of the parser, in order to get the position of + the latest token in the case of an error. *) val content : t -> string (** Extract the token matched by the rule *) @@ -33,15 +35,14 @@ val tokenize : (t -> 'a) -> t -> unit -> 'a * Lexing.position * Lexing.position val rollback : t -> unit (** Rollback the latest token matched *) -(** {1 State in expressions} +(** {1 State in expressions} - The comment system is terrible. The same symbol can be used for : - - starting a comment - - inequality operation + The comment system is terrible. The same symbol can be used for : + - starting a comment + - inequality operation - In order to manage this, I try to identify the context in a very basic way, - using a stack for determining the token to send. -*) + In order to manage this, I try to identify the context in a very basic way, + using a stack for determining the token to send. *) type lexer = t -> Tokens.token and buffer_builder = ?nested:bool -> Buffer.t -> t -> Tokens.token @@ -64,14 +65,14 @@ type state = | String of stringWraper (** String enclosed by [''] *) | MString of int (** String enclosed by [{}]*) | EndString of stringWraper - (** State raised just before closing the string. - The buffer is rollbacked and the position is the closing symbol. *) + (** State raised just before closing the string. The buffer is rollbacked + and the position is the closing symbol. *) | Expression (** Expression where [!] is an operator *) val pp_state : Format.formatter -> state -> unit val state : t -> state option -(** Get the current state for the lexer. +(** Get the current state for the lexer. @return [None] when in the default state *) @@ -81,11 +82,14 @@ val enter_state : t -> state -> unit val leave_state : t -> unit (** Leave the current state *) +val clear_state : t -> unit +(** Remove all the elements from the stack *) + val overlay : t -> lexer -> lexer val start_recovery : t -> unit -(** Set the lexer in recovery mode, the lexer raise this mode after an error, - in order to ignore the further errors until a new location *) +(** Set the lexer in recovery mode, the lexer raise this mode after an error, in + order to ignore the further errors until a new location *) val is_recovery : t -> bool (** Check if the lexer is in recovery mode *) diff --git a/lib/qparser/lexer.ml b/lib/qparser/lexer.ml index 814c97f..0bd214a 100644 --- a/lib/qparser/lexer.ml +++ b/lib/qparser/lexer.ml @@ -1,6 +1,4 @@ -(** - Lexer using sedlex - *) +(** Lexer using sedlex *) open Tokens open StdLabels @@ -12,7 +10,8 @@ exception EOF (* Extract the location name from the pattern *) let location_name = Str.regexp {|# *\(.*\)|} -(** Remove all the expression state when we are leaving the expression itself. *) +(** Remove all the expression state when we are leaving the expression itself. +*) let rec leave_expression buffer = match Lexbuf.state buffer with | Some Lexbuf.Expression -> @@ -21,7 +20,7 @@ let rec leave_expression buffer = | _ -> () (** Try to read the identifier and check if this is a function, a keyword, or - just a variable. + just a variable. See the tests [Syntax.Operator2] and [Syntax.Call Nl] for two cases. *) let build_ident buffer = @@ -124,8 +123,7 @@ let rec read_long_string : ?nested:bool -> int -> Buffer.t -> Lexbuf.t -> token rollbacked, leaving the state in [Lexbuf.EndString _]. The next call to [main] will call the associated function, effectively - leaving the string mode in the parser. - *) + leaving the string mode in the parser. *) let rec read_quoted_string : Lexbuf.stringWraper -> Lexbuf.buffer_builder = fun f ?(nested = false) buf buffer -> let lexbuf = Lexbuf.buffer buffer in @@ -153,11 +151,9 @@ let rec read_quoted_string : Lexbuf.stringWraper -> Lexbuf.buffer_builder = (f.wrap ~nested (read_quoted_string f)) buf buffer | _ -> raise Not_found -(** Track the kind of nested string inside a multiline string inside a - comment. +(** Track the kind of nested string inside a multiline string inside a comment. - Some constructions are not allowed in this specific case (see later) -*) + Some constructions are not allowed in this specific case (see later) *) type commentedString = None | Quote | DQuote let rec skip_comment buffer = @@ -333,6 +329,10 @@ let main buffer = in parser buffer +(** Function used inside the dynamics expressions. Here, we give the EOF token + to the parser. *) +let dynamics buffer = try main buffer with EOF -> Tokens.EOF + let rec discard buffer = let () = Lexbuf.start_recovery buffer in let lexbuf = Lexbuf.buffer buffer in @@ -347,7 +347,6 @@ let rec discard buffer = We are here because an error was raised, so can have any situation (for example a missing quote). *) - leave_expression buffer; - () + Lexbuf.clear_state buffer | any -> discard buffer | _ -> raise EOF diff --git a/lib/qparser/lexer.mli b/lib/qparser/lexer.mli index 854bb1e..70902e6 100644 --- a/lib/qparser/lexer.mli +++ b/lib/qparser/lexer.mli @@ -18,3 +18,5 @@ val discard : Lexbuf.t -> unit val main : Lexbuf.t -> Tokens.token (** Main entry point. This function is called after each token returned *) + +val dynamics : Lexbuf.t -> Tokens.token diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly index d075e3e..1caf962 100644 --- a/lib/qparser/parser.mly +++ b/lib/qparser/parser.mly @@ -17,13 +17,15 @@ module Helper = Qsp_syntax.S.Helper(Analyzer.Expression) %} -%parameter<Analyzer: Qsp_syntax.S.Analyzer> +%parameter<Analyzer: Qsp_syntax.Analyzer.T> %start <(Analyzer.context -> Analyzer.Location.t)>main -%on_error_reduce expression instruction unary_operator assignation_operator +%start<(Analyzer.context -> Analyzer.Location.t)>dynamics + +%on_error_reduce instruction unary_operator assignation_operator %% -main: +main: | before_location* start_location EOL+ @@ -34,6 +36,21 @@ main: fun context -> Analyzer.Location.location context $loc instructions } +dynamics: + | EOL* + instructions = line_statement+ + EOF + { + let instructions = List.map instructions ~f:(Analyzer.Instruction.v) in + fun context -> Analyzer.Location.location context $loc instructions + } + | EOL* + b = inlined_block(EOF) + { + let instruction = (Analyzer.Instruction.v b) in + fun context -> Analyzer.Location.location context $loc [instruction] + } + before_location: | EOL {} | COMMENT EOL { } diff --git a/lib/qparser/qsp_expression.mly b/lib/qparser/qsp_expression.mly index c6b7564..f037051 100644 --- a/lib/qparser/qsp_expression.mly +++ b/lib/qparser/qsp_expression.mly @@ -27,26 +27,26 @@ { ex } | op = unary_operator expr = expression - { Analyzer.Expression.uoperator $loc op expr } + { Analyzer.Expression.uoperator ~ctx:{f=(fun _ -> None)} $loc op expr } %prec NO | expr1 = expression op = binary_operator expr2 = expression - { Analyzer.Expression.boperator $loc op expr1 expr2 } + { Analyzer.Expression.boperator ~ctx:{f=(fun _ -> None)} $loc op expr1 expr2 } | v = delimited(TEXT_MARKER, literal*, TEXT_MARKER) - { Analyzer.Expression.literal $loc v } - | i = INTEGER { Analyzer.Expression.integer $loc i } - | v = variable { Analyzer.Expression.ident v } + { Analyzer.Expression.literal ~ctx:{f=(fun _ -> None)} $loc v } + | i = INTEGER { Analyzer.Expression.integer ~ctx:{f=(fun _ -> None)} $loc i } + | v = variable { Analyzer.Expression.ident ~ctx:{f=(fun _ -> None)} v } %prec p_variable | k = FUNCTION arg = argument(expression) { - (Analyzer.Expression.function_ $loc k arg) + (Analyzer.Expression.function_ ~ctx:{f=(fun _ -> None)} $loc k arg) } | k = FUNCTION_NOARGS { - (Analyzer.Expression.function_ $loc k []) + (Analyzer.Expression.function_ ~ctx:{f=(fun _ -> None)} $loc k []) } literal: | v = LITERAL { Qsp_syntax.T.Text v } diff --git a/lib/qparser/tokens.mly b/lib/qparser/tokens.mly index 0ba5486..42856ef 100644 --- a/lib/qparser/tokens.mly +++ b/lib/qparser/tokens.mly @@ -20,6 +20,7 @@ %token AND OR %token EOL +%token EOF %token <string>IDENT %token <string>LITERAL diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml index 918d8e6..04490af 100644 --- a/lib/syntax/S.ml +++ b/lib/syntax/S.ml @@ -8,11 +8,20 @@ (** {1 Generic types used in the module} *) -type pos = Lexing.position * Lexing.position +type position = Lexing.position = { + pos_fname : string; + pos_lnum : int; + pos_bol : int; + pos_cnum : int; +} +[@@deriving eq, ord] + +type pos = position * position [@@deriving eq, ord] (** The type pos is used to track the starting and ending position for the given location. *) type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option } +[@@deriving eq, ord] (** Describe a variable, using the name in capitalized text, and an optionnal index. @@ -20,6 +29,9 @@ type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option } type ('a, 'b) clause = pos * 'a * 'b list +type extract_context = { f : 'a. 'a Type.Id.t -> 'a option } [@@unboxed] +(** Extract the given value from the context *) + (** {1 Checker Signature} *) (** Represent the evaluation over an expression *) @@ -31,22 +43,22 @@ module type Expression = sig (** External type used outside of the module *) val v : t -> t' - val ident : (pos, t) variable -> t + val ident : ctx:extract_context -> (pos, t) variable -> t (* Basic values, text, number… *) - val integer : pos -> string -> t - val literal : pos -> t T.literal list -> t + val integer : ctx:extract_context -> pos -> string -> t + val literal : ctx:extract_context -> pos -> t T.literal list -> t - val function_ : pos -> T.function_ -> t list -> t + val function_ : ctx:extract_context -> pos -> T.function_ -> t list -> t (** Call a function. The functions list is hardcoded in lib/lexer.mll *) - val uoperator : pos -> T.uoperator -> t -> t + val uoperator : ctx:extract_context -> pos -> T.uoperator -> t -> t (** Unary operator like [-123] or [+'Text']*) - val boperator : pos -> T.boperator -> t -> t -> t + val boperator : ctx:extract_context -> pos -> T.boperator -> t -> t -> t (** Binary operator, for a comparaison, or an operation *) end @@ -99,41 +111,6 @@ module type Location = sig val location : context -> pos -> instruction list -> t end -(** {1 Unified module used by the parser} *) - -module type Analyzer = sig - val identifier : string - (** Identifier for the module *) - - val description : string - (** Short description*) - - val active : bool ref - (** Is the test active or not *) - - val is_global : bool - (** Declare the checker as global. It requires to run over the whole file and - will be disabled if the application only check a single location. - - Also, the test will be disabled if a syntax error is reported during the - parsing, because this tell that I haven’t been able to analyse the whole - source code. *) - - type context - (** Context used to keep information during the whole test *) - - val initialize : unit -> context - (** Initialize the context before starting to parse the content *) - - module Expression : Expression - module Instruction : Instruction with type expression := Expression.t' - - module Location : - Location with type instruction := Instruction.t' and type context := context - - val finalize : context -> (string * Report.t) list -end - (** Helper module used in order to convert elements from the differents representation levels. diff --git a/lib/syntax/analyzer.ml b/lib/syntax/analyzer.ml new file mode 100644 index 0000000..22c1696 --- /dev/null +++ b/lib/syntax/analyzer.ml @@ -0,0 +1,43 @@ +module type T = sig + type ex + (** The type is not given, but we do not have much choice. Because of + recursive definition, the type is left blank here, but constraint will be + defined later, and this type shall be a [ex] *) + + val depends : ex list + (** Dependencies are module required to be executed before. The result for + them can be accessed with the ctx argument given in the functions *) + + val identifier : string + (** Identifier for the module *) + + val description : string + (** Short description*) + + val active : bool ref + (** Is the test active or not *) + + val is_global : bool + (** Declare the checker as global. It requires to run over the whole file and + will be disabled if the application only check a single location. + + Also, the test will be disabled if a syntax error is reported during the + parsing, because this tell that I haven’t been able to analyse the whole + source code. *) + + type context + (** Context used to keep information during the whole test *) + + val initialize : unit -> context + (** Initialize the context before starting to parse the content *) + + module Expression : S.Expression + module Instruction : S.Instruction with type expression := Expression.t' + + module Location : + S.Location + with type instruction := Instruction.t' + and type context := context + + val finalize : context -> (string * Report.t) list +end diff --git a/lib/syntax/catalog.ml b/lib/syntax/catalog.ml deleted file mode 100644 index b516976..0000000 --- a/lib/syntax/catalog.ml +++ /dev/null @@ -1,48 +0,0 @@ -type ex = - | E : { - module_ : - (module S.Analyzer - with type Expression.t = 'a - and type Expression.t' = 'b - and type Instruction.t = 'c - and type Instruction.t' = 'd - and type Location.t = 'e - and type context = 'f); - expr_witness : 'a Type.Id.t; - expr' : 'b Type.Id.t; - instr_witness : 'c Type.Id.t; - instr' : 'd Type.Id.t; - location_witness : 'e Type.Id.t; - context : 'f Type.Id.t; - } - -> ex (** Type of check to apply *) - -let build : - (module S.Analyzer - with type Expression.t = _ - and type Expression.t' = _ - and type Instruction.t = _ - and type Instruction.t' = _ - and type Location.t = 'a - and type context = _) -> - 'a Type.Id.t * ex = - fun module_ -> - let expr_witness = Type.Id.make () - and expr' = Type.Id.make () - and instr_witness = Type.Id.make () - and instr' = Type.Id.make () - and location_witness = Type.Id.make () - and context = Type.Id.make () in - let t = - E - { - module_; - expr_witness; - expr'; - instr_witness; - instr'; - location_witness; - context; - } - in - (location_witness, t) diff --git a/lib/syntax/dune b/lib/syntax/dune index 666273f..4bc26be 100644 --- a/lib/syntax/dune +++ b/lib/syntax/dune @@ -1,6 +1,4 @@ (library (name qsp_syntax) - - (preprocess (pps - ppx_deriving.show ppx_deriving.enum - ppx_deriving.eq ))) + (preprocess + (pps ppx_deriving.show ppx_deriving.enum ppx_deriving.ord ppx_deriving.eq))) diff --git a/lib/syntax/identifier.ml b/lib/syntax/identifier.ml new file mode 100644 index 0000000..422171c --- /dev/null +++ b/lib/syntax/identifier.ml @@ -0,0 +1,55 @@ +type t = + | E : { + module_ : + (module Analyzer.T + with type Expression.t = 'a + and type Expression.t' = 'b + and type Instruction.t = 'c + and type Instruction.t' = 'd + and type Location.t = 'e + and type context = 'f + and type ex = t); + expr_witness : 'a Type.Id.t; + expr' : 'b Type.Id.t; + instr_witness : 'c Type.Id.t; + instr' : 'd Type.Id.t; + location_witness : 'e Type.Id.t; + context : 'f Type.Id.t; + } + -> t (** Type of check to apply *) + +let get_module : t -> (module Analyzer.T) = + fun (E { module_; _ }) -> (module_ :> (module Analyzer.T)) + +let build : + ?expression_id:'a Type.Id.t -> + ?location_id:'b Type.Id.t -> + ?context_id:'c Type.Id.t -> + (module Analyzer.T + with type Expression.t = 'a + and type Expression.t' = _ + and type Instruction.t = _ + and type Instruction.t' = _ + and type Location.t = 'b + and type context = 'c + and type ex = t) -> + t = + fun ?expression_id ?location_id ?context_id module_ -> + let expr_witness = + match expression_id with None -> Type.Id.make () | Some v -> v + and expr' = Type.Id.make () + and instr_witness = Type.Id.make () + and instr' = Type.Id.make () + and location_witness = + match location_id with Some v -> v | None -> Type.Id.make () + and context = match context_id with Some v -> v | None -> Type.Id.make () in + E + { + module_; + expr_witness; + expr'; + instr_witness; + instr'; + location_witness; + context; + } diff --git a/lib/syntax/catalog.mli b/lib/syntax/identifier.mli index a256c17..4c6387b 100644 --- a/lib/syntax/catalog.mli +++ b/lib/syntax/identifier.mli @@ -1,13 +1,14 @@ -type ex = +type t = | E : { module_ : - (module S.Analyzer + (module Analyzer.T with type Expression.t = 'a and type Expression.t' = 'b and type Instruction.t = 'c and type Instruction.t' = 'd and type Location.t = 'e - and type context = 'f); + and type context = 'f + and type ex = t); expr_witness : 'a Type.Id.t; expr' : 'b Type.Id.t; instr_witness : 'c Type.Id.t; @@ -15,16 +16,22 @@ type ex = location_witness : 'e Type.Id.t; context : 'f Type.Id.t; } - -> ex (** Type of check to apply *) + -> t (** Type of check to apply *) val build : - (module S.Analyzer - with type Expression.t = _ + ?expression_id:'a Type.Id.t -> + ?location_id:'b Type.Id.t -> + ?context_id:'c Type.Id.t -> + (module Analyzer.T + with type Expression.t = 'a and type Expression.t' = _ and type Instruction.t = _ and type Instruction.t' = _ - and type Location.t = 'a - and type context = _) -> - 'a Type.Id.t * ex + and type Location.t = 'b + and type context = 'c + and type ex = t) -> + t (** Build a new check from a module following S.Analyzer signature. ypeid Return the result type which hold the final result value, and checker itself. *) + +val get_module : t -> (module Analyzer.T) diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml index 0074df8..c3edcdc 100644 --- a/lib/syntax/tree.ml +++ b/lib/syntax/tree.ml @@ -7,9 +7,12 @@ let active = ref true type context = unit +let depends = [] let initialize = Fun.id let finalize () = [] +type ex = Identifier.t + module Ast = struct type 'a literal = 'a T.literal = Text of string | Expression of 'a [@@deriving eq, show] @@ -88,24 +91,36 @@ end = struct Hashtbl.hash (f pos, name, List.map ~f:(hash f) args) let v : t -> t' = fun t -> t - let integer : S.pos -> string -> t = fun pos i -> Ast.Integer (pos, i) - - let literal : S.pos -> t T.literal list -> t = - fun pos l -> Ast.Literal (pos, l) - - let function_ : S.pos -> T.function_ -> t list -> t = - fun pos name args -> Ast.Function (pos, name, args) - - let uoperator : S.pos -> T.uoperator -> t -> t = - fun pos op expression -> Ast.Op (pos, op, expression) - let boperator : S.pos -> T.boperator -> t -> t -> t = - fun pos op op1 op2 -> + let integer : ctx:S.extract_context -> S.pos -> string -> t = + fun ~ctx pos i -> + ignore ctx; + Ast.Integer (pos, i) + + let literal : ctx:S.extract_context -> S.pos -> t T.literal list -> t = + fun ~ctx pos l -> + ignore ctx; + Ast.Literal (pos, l) + + let function_ : ctx:S.extract_context -> S.pos -> T.function_ -> t list -> t = + fun ~ctx pos name args -> + ignore ctx; + Ast.Function (pos, name, args) + + let uoperator : ctx:S.extract_context -> S.pos -> T.uoperator -> t -> t = + fun ~ctx pos op expression -> + ignore ctx; + Ast.Op (pos, op, expression) + + let boperator : ctx:S.extract_context -> S.pos -> T.boperator -> t -> t -> t = + fun ~ctx pos op op1 op2 -> + ignore ctx; let op1 = op1 and op2 = op2 in Ast.BinaryOp (pos, op, op1, op2) - let ident : (S.pos, t) S.variable -> t = - fun { pos; name; index } -> + let ident : ctx:S.extract_context -> (S.pos, t) S.variable -> t = + fun ~ctx { pos; name; index } -> + ignore ctx; let index = Option.map (fun i -> i) index in Ast.Ident { pos; name; index } end diff --git a/lib/syntax/tree.mli b/lib/syntax/tree.mli index 9ed442b..097a7ac 100644 --- a/lib/syntax/tree.mli +++ b/lib/syntax/tree.mli @@ -1,9 +1,7 @@ -(** - Implementation for S.Analyzer for building a complete Ast. +(** Implementation for S.Analyzer for building a complete Ast. Used in the unit test in order to check if the grammar is interpreted as - expected, not really usefull over a big qsp. - *) + expected, not really usefull over a big qsp. *) (** This module is the result of the evaluation. *) module Ast : sig @@ -53,8 +51,9 @@ module Expression : sig end include - S.Analyzer + Analyzer.T with module Expression := Expression and type Instruction.t' = S.pos Ast.statement and type Location.t = S.pos * S.pos Ast.statement list and type context = unit + and type ex = Identifier.t @@ -89,7 +89,7 @@ will not report this usage when an integer converted into a string this way. In a single if branch, check if the same is repeated more than one once. In this case, only the first case is executed and the other test is ignored. -A warining will be raised here: +A warning will be raised here: if $value = '1': ! Do something diff --git a/test/dup_cases.ml b/test/dup_cases.ml index 8b9f846..76a1157 100644 --- a/test/dup_cases.ml +++ b/test/dup_cases.ml @@ -28,8 +28,7 @@ elseif rnd: end |} [] -(** The same test in two differents block shall be considered as a duplicate. - *) +(** The same test in two differents block shall be considered as a duplicate. *) let ok_act () = _test_instruction {| @@ -61,14 +60,13 @@ end { level = Warn; loc = _position; - message = "This case is duplicated line(s) 5"; + message = "This case is duplicated line(s) 4"; }; ] let duplicate_root_test () = _test_instruction - {| -if args[0] = 1: + {|if args[0] = 1: 0 end if args[0] = 1: @@ -81,7 +79,7 @@ end { level = Warn; loc = _position; - message = "This case is duplicated line(s) 6"; + message = "This case is duplicated line(s) 4"; }; ] diff --git a/test/dynamics.ml b/test/dynamics.ml new file mode 100644 index 0000000..ad980f4 --- /dev/null +++ b/test/dynamics.ml @@ -0,0 +1,93 @@ +module Check = Make_checkTest.M (Qsp_checks.Dynamics) +module S = Qsp_syntax.S + +let position = (Lexing.dummy_pos, Lexing.dummy_pos) + +module Testable = struct + type pos = S.pos + + let pp_pos = Qsp_syntax.Report.pp_pos + let equal_pos : pos -> pos -> bool = fun _ _ -> true + + type t = Qsp_checks.Dynamics.text = { content : string; position : pos } + [@@deriving show, eq] + + let v = Alcotest.list (Alcotest.testable pp equal) +end + +let _parse : string -> Testable.t list -> unit = + fun literal expected -> + let context = Qsp_checks.Dynamics.initialize () in + (* The result of the parsing can be discarded, the usefull information is in + the context *) + let result = + Check._parse ~context Qparser.Analyzer.Dynamic (literal ^ "\n") + in + match result with + | Ok _ -> + let actual : Qsp_checks.Dynamics.text List.t = + Qsp_checks.Dynamics.dynamics_string context |> List.of_seq + in + let msg = literal in + Alcotest.(check' Testable.v ~msg ~expected ~actual) + | Error _ -> raise (Failure "Syntax error") + +let test_direct () = + _parse "dynamic '$a = 1'" + [ { Qsp_checks.Dynamics.content = "$a = 1"; position } ] + +let test_indirect () = + _parse "$test = '$a = 1' & dynamic $test" + [ { Qsp_checks.Dynamics.content = "$a = 1"; position } ] + +let test_indirect_array () = + _parse "$test[0] = '$a = 1' & dynamic $test[0]" + [ { Qsp_checks.Dynamics.content = "$a = 1"; position } ]; + + _parse "$test['a'] = '$a = 1' & dynamic $test['a']" + [ { Qsp_checks.Dynamics.content = "$a = 1"; position } ]; + + _parse "$test[0] = '$a = 1' & dynamic $test[1]" [] + +(** If a variable is identified as dynamic, check all the differents values this + variable can have *) +let test_reassignation () = + _parse + {|$test = '$a = 1' + $test = '$a = 2' + dynamic $test|} + [ + { Qsp_checks.Dynamics.content = "$a = 1"; position }; + { Qsp_checks.Dynamics.content = "$a = 2"; position }; + ] + +(** If the variable contains a dynamic assignation, blacklist it from being + checkable*) +let test_blacklist () = + _parse {|$test = '$a = 1' + $test = $b + '' + dynamic $test|} [] + +(** Ignore string template because this can be anything *) +let test_template_str () = _parse "dynamic '$a = <<$other>>'" [] + +let test_template_str2 () = + _parse {|dynamic '$a = <<"other">>'|} + [ { Qsp_checks.Dynamics.content = "$a = other"; position } ] + +let test_template_int () = + _parse "dynamic '$a = <<other>>'" + [ { Qsp_checks.Dynamics.content = "$a = 0"; position } ] + +let test = + ( "Dynamic evaluation checker", + [ + Alcotest.test_case "direct" `Quick test_direct; + Alcotest.test_case "indirect" `Quick test_indirect; + Alcotest.test_case "indirect array" `Quick test_indirect_array; + Alcotest.test_case "template" `Quick test_template_str; + Alcotest.test_case "template" `Quick test_template_str2; + Alcotest.test_case "template int" `Quick test_template_int; + Alcotest.test_case "reassignation" `Quick test_reassignation; + Alcotest.test_case "blacklist" `Quick test_blacklist; + ] ) diff --git a/test/get_type.ml b/test/get_type.ml index 55f087e..56b4689 100644 --- a/test/get_type.ml +++ b/test/get_type.ml @@ -3,79 +3,84 @@ module T = Qsp_syntax.T let _position = (Lexing.dummy_pos, Lexing.dummy_pos) -let type_of : Get_type.t Alcotest.testable = - Alcotest.testable Get_type.pp Get_type.equal +let type_of : Get_type.Expression.t Alcotest.testable = + Alcotest.testable Get_type.Expression.pp Get_type.Expression.equal + +let ctx = Qsp_syntax.S.{ f = (fun _ -> None) } let add_number () = let actual = - Get_type.boperator _position T.Plus - (Get_type.integer _position "0") - (Get_type.integer _position "1") + Get_type.Expression.boperator ~ctx _position T.Plus + (Get_type.Expression.integer ~ctx _position "0") + (Get_type.Expression.integer ~ctx _position "1") in - let expected = Get_type.(Raw Integer) in + let expected = Get_type.Expression.(Raw Integer) in let msg = "Adding integer" in Alcotest.(check' type_of ~msg ~expected ~actual) let add_literal_number () = let actual = - Get_type.boperator _position T.Plus - (Get_type.literal _position [ T.Text "2" ]) - (Get_type.integer _position "1") + Get_type.Expression.boperator ~ctx _position T.Plus + (Get_type.Expression.literal ~ctx _position [ T.Text "2" ]) + (Get_type.Expression.integer ~ctx _position "1") in - let expected = Get_type.(Raw Integer) in + let expected = Get_type.Expression.(Raw Integer) in let msg = "A string containing integer is considered as integer" in Alcotest.(check' type_of ~msg ~expected ~actual) let concat_text () = let actual = - Get_type.boperator _position T.Plus - (Get_type.literal _position [ T.Text "a" ]) - (Get_type.integer _position "1") + Get_type.Expression.boperator ~ctx _position T.Plus + (Get_type.Expression.literal ~ctx _position [ T.Text "a" ]) + (Get_type.Expression.integer ~ctx _position "1") in - let expected = Get_type.(Raw String) in + let expected = Get_type.Expression.(Raw String) in let msg = "Concatenate" in Alcotest.(check' type_of ~msg ~expected ~actual) let literal_1 () = let actual = - Get_type.literal _position [ T.Expression (Get_type.Raw Integer) ] - and expected = Get_type.(Raw NumericString) in + Get_type.Expression.literal ~ctx _position + [ T.Expression (Get_type.Expression.Raw Integer) ] + and expected = Get_type.Expression.(Raw NumericString) in let msg = "" in Alcotest.(check' type_of ~msg ~expected ~actual) let literal_2 () = let actual = - Get_type.literal _position - Get_type.[ T.Text "1"; T.Expression (Raw Integer) ] - and expected = Get_type.(Raw NumericString) in + Get_type.Expression.literal ~ctx _position + Get_type.Expression.[ T.Text "1"; T.Expression (Raw Integer) ] + and expected = Get_type.Expression.(Raw NumericString) in let msg = "" in Alcotest.(check' type_of ~msg ~expected ~actual) let literal_3 () = let actual = - Get_type.literal _position - Get_type.[ T.Text "b"; T.Expression (Raw Integer) ] - and expected = Get_type.(Raw String) in + Get_type.Expression.literal ~ctx _position + Get_type.Expression.[ T.Text "b"; T.Expression (Raw Integer) ] + and expected = Get_type.Expression.(Raw String) in let msg = "" in Alcotest.(check' type_of ~msg ~expected ~actual) let literal_4 () = let actual = - Get_type.literal _position [ T.Expression (Get_type.Variable Integer) ] - and expected = Get_type.(Variable NumericString) in + Get_type.Expression.literal ~ctx _position + Get_type.Expression.[ T.Expression (Variable Integer) ] + and expected = Get_type.Expression.(Variable NumericString) in let msg = "" in Alcotest.(check' type_of ~msg ~expected ~actual) let min () = - let actual = Get_type.function_ _position T.Min [] in - let expected = Get_type.(Raw Bool) in + let actual = Get_type.Expression.function_ ~ctx _position T.Min [] in + let expected = Get_type.Expression.(Raw Bool) in let msg = "The function min without argument return a default value" in Alcotest.(check' type_of ~msg ~expected ~actual); let actual = - Get_type.function_ _position T.Min [ Get_type.literal _position [] ] + Get_type.Expression.function_ ~ctx _position T.Min + [ Get_type.Expression.literal ~ctx _position [] ] in - let expected = Get_type.(Variable NumericString) in + let expected = Get_type.Expression.(Variable NumericString) in let msg = "The function min with a literal will take the literal as the name of an \ array" @@ -83,10 +88,11 @@ let min () = Alcotest.(check' type_of ~msg ~expected ~actual); let actual = - Get_type.function_ _position T.Min - [ Get_type.integer _position ""; Get_type.integer _position "" ] + Get_type.Expression.function_ ~ctx _position T.Min + Get_type.Expression. + [ integer ~ctx _position ""; integer ~ctx _position "" ] in - let expected = Get_type.(Raw Integer) in + let expected = Get_type.Expression.(Raw Integer) in let msg = "With two or more arguments, return the type of the first one" in Alcotest.(check' type_of ~msg ~expected ~actual) diff --git a/test/literals.ml b/test/literals.ml index f98fa8f..2685538 100644 --- a/test/literals.ml +++ b/test/literals.ml @@ -107,6 +107,20 @@ let multiple_expression () = ] )); ] +let int_expression () = + _test_instruction {|"<<expr2>>"|} + [ + Tree.Ast.Expression + (Tree.Ast.Literal + ( _position, + [ + T.Expression + (Tree.Ast.Ident + { Tree.Ast.pos = _position; name = "EXPR2"; index = None }); + T.Text ""; + ] )); + ] + let test = ( "Literals", [ @@ -127,4 +141,5 @@ let test = Alcotest.test_case "elements_sequence" `Quick elements_sequence; Alcotest.test_case "expression" `Quick expression; Alcotest.test_case "multiple_expression" `Quick multiple_expression; + Alcotest.test_case "multiple_expression" `Quick int_expression; ] ) diff --git a/test/location.ml b/test/location.ml index a1939f4..decf270 100644 --- a/test/location.ml +++ b/test/location.ml @@ -5,7 +5,7 @@ let _position = (Lexing.dummy_pos, Lexing.dummy_pos) let error_message = [ ( "Location", - Check. + Make_checkTest. { level = Error; loc = _position; @@ -18,11 +18,21 @@ let ok_upper () = Check.global_check "gt 'LOCATION'" [] let missing_gt () = Check.global_check "gt 'unknown_place'" error_message let missing_gs () = Check.global_check "gs 'unknown_place'" error_message +let act_missing_gs () = + Check.global_check {| +act "test": gs 'unknown_place'|} error_message + +let if_missing_gs () = + Check.global_check {| + if 0: gs 'unknown_place'|} error_message + let test = - ( "Locations", + ( __FILE__, [ Alcotest.test_case "Ok" `Quick ok; Alcotest.test_case "Ok upper" `Quick ok_upper; Alcotest.test_case "Missing GT" `Quick missing_gt; Alcotest.test_case "Missing GS" `Quick missing_gs; + Alcotest.test_case "Missing GS in block" `Quick act_missing_gs; + Alcotest.test_case "Missing GS in block'" `Quick if_missing_gs; ] ) diff --git a/test/make_checkTest.ml b/test/make_checkTest.ml index d3ad358..7ffd17c 100644 --- a/test/make_checkTest.ml +++ b/test/make_checkTest.ml @@ -1,69 +1,92 @@ -(** Build a parser for a specific check module *) -module M (Check : Qsp_syntax.S.Analyzer) = struct - module S = Qsp_syntax.S +module S = Qsp_syntax.S + +type pos = S.pos - let pp_pos = Qsp_syntax.Report.pp_pos +let pp_pos = Qsp_syntax.Report.pp_pos +let equal_pos : pos -> pos -> bool = fun _ _ -> true - type pos = S.pos +type t = Qsp_syntax.Report.t = { + level : Qsp_syntax.Report.level; + loc : pos; + message : string; +} +[@@deriving show, eq] - let equal_pos : pos -> pos -> bool = fun _ _ -> true +let report : t list Alcotest.testable = + Alcotest.list @@ Alcotest.testable Qsp_syntax.Report.pp equal - type t = Qsp_syntax.Report.t = { - level : Qsp_syntax.Report.level; - loc : pos; - message : string; - } - [@@deriving show, eq] +let report_global : (string * t) list Alcotest.testable = + Alcotest.list + @@ Alcotest.pair Alcotest.string + (Alcotest.testable Qsp_syntax.Report.pp equal) - let report : t list Alcotest.testable = - Alcotest.list @@ Alcotest.testable Qsp_syntax.Report.pp equal +(** Build a parser for a specific check module *) +module M + (Checkable : Qsp_syntax.Analyzer.T with type ex = Qsp_syntax.Identifier.t) = +struct + let context_id = Type.Id.make () - let report_global : (string * t) list Alcotest.testable = - Alcotest.list - @@ Alcotest.pair Alcotest.string - (Alcotest.testable Qsp_syntax.Report.pp equal) + (* Build the test module with a single test inside. *) + module Check = Qsp_checks.Check.Make (struct + let t = [| Qsp_syntax.Identifier.build ~context_id (module Checkable) |] + end) - let parse : - ?context:Check.context -> + let _parse : + ?context:Checkable.context -> + Qparser.Analyzer.lexer -> string -> (Check.Location.t Qparser.Analyzer.result, t) result = - fun ?context content -> + fun ?context lexer content -> let lexing = Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf in - let context = Option.value context ~default:(Check.initialize ()) in - Qparser.Analyzer.parse (module Check) lexing context + (* Initialize the context *inside* the Check module. This works by + editing the context we created. + + We have the context id (created at the begining of the module), which is + required to get the value. *) + let context = + match context with + | None -> Check.initialize () + | Some c -> ( + let init = Check.initialize () in + match Qsp_checks.Check.set context_id init.(0) c with + | None -> raise Not_found + | Some v -> + init.(0) <- v; + init) + in + Qparser.Analyzer.parse (module Check) lexer lexing context let get_report : (Check.Location.t Qparser.Analyzer.result, Qsp_syntax.Report.t) result -> Qsp_syntax.Report.t list = function | Ok v -> v.report - | Error _ -> failwith "Error" + | Error msg -> failwith msg.message let _test_instruction : string -> t list -> unit = fun literal expected -> - let _location = Printf.sprintf {|# Location -%s -------- |} literal in - let actual = get_report @@ parse _location and msg = literal in + let actual = get_report @@ _parse Qparser.Analyzer.Dynamic literal + and msg = literal in Alcotest.(check' report ~msg ~expected ~actual) - (** Run a test over the whole file. - The parsing of the content shall not report any error. - *) + (** Run a test over the whole file. The parsing of the content shall not + report any error. *) let global_check : string -> (string * t) list -> unit = fun literal expected -> let _location = Printf.sprintf {|# Location %s ------- |} literal in - let context = Check.initialize () in - let actual = get_report @@ parse ~context _location in + let context = Checkable.initialize () in + let actual = + get_report @@ _parse ~context Qparser.Analyzer.Location _location + in let () = Alcotest.( check' report ~msg:"Error reported during parsing" ~expected:[] ~actual) in let msg = literal in - let actual = Check.finalize context in + let actual = Checkable.finalize context in Alcotest.(check' report_global ~msg ~expected ~actual) end diff --git a/test/qsp_parser_test.ml b/test/qsp_parser_test.ml index 43f9cb3..4ae5a4c 100644 --- a/test/qsp_parser_test.ml +++ b/test/qsp_parser_test.ml @@ -11,4 +11,5 @@ let () = Nested_string.test; Location.test; Dup_cases.test; + Dynamics.test; ] diff --git a/test/syntax.ml b/test/syntax.ml index db449b1..ce3e89e 100644 --- a/test/syntax.ml +++ b/test/syntax.ml @@ -4,7 +4,8 @@ module Check = Qsp_checks.Check module S = Qsp_syntax.S module T = Qsp_syntax.T -let location_id, e1 = Qsp_syntax.Catalog.build (module Tree) +let location_id = Type.Id.make () +let e1 = Qsp_syntax.Identifier.build ~location_id (module Tree) module Parser = Check.Make (struct let t = [| e1 |] @@ -28,7 +29,9 @@ let parse : string -> (S.pos location, Qsp_syntax.Report.t) result = Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf in let context = Parser.initialize () in - Qparser.Analyzer.parse (module Parser) lexing context + Qparser.Analyzer.parse + (module Parser) + Qparser.Analyzer.Location lexing context |> Result.map (fun v -> (* Uncatched excteptions here, but we are in the tests… If it’s fail here I have an error in the code. *) diff --git a/test/syntax_error.ml b/test/syntax_error.ml index b92cf28..9d51cf3 100644 --- a/test/syntax_error.ml +++ b/test/syntax_error.ml @@ -57,14 +57,15 @@ let elseif_no_column () = } let unclosed_paren () = - _test_instruction - {|(1 - |} + let expected = { level = Error; loc = _position; message = "Unexpected '('. Did you forgot a function before ?"; } + in + _test_instruction "(1" expected; + _test_instruction "'<<(1>>'" expected let act_no_column () = _test_instruction @@ -113,8 +114,12 @@ let missing_operand () = () let unknow_function () = - _test_instruction "a = ran(1, 2)" + let expected = { level = Error; loc = _position; message = "Unexpected expression here." } + in + _test_instruction "ran(1, 2)" expected; + _test_instruction "'<<ran(1, 2)>>'" expected; + _test_instruction "rand(1,2))" expected let inline_elif () = _test_instruction {| @@ -194,9 +199,8 @@ let missing_comparable () = _test_instruction "1 <= or 0" result; _test_instruction "1 = or 0" result -(** This code looks like a new location, but is actualy invalid. - The application should report the old location. - *) +(** This code looks like a new location, but is actualy invalid. The application + should report the old location. *) let location_change () = let result = { @@ -272,6 +276,20 @@ let nested_string_mess () = |} { level = Error; loc = _position; message = "Unclosed string" } +let unexpected_bracket () = + let expected = + { level = Error; loc = _position; message = "Unbalanced paren" } + in + _test_instruction {|a[]]|} expected; + _test_instruction {|"<<a[]]>>"|} expected; + _test_instruction "'<<rand(1,2))>>'" expected + +let missing_operator () = + _test_instruction {| +'' + $func('f', '') '' +|} + { level = Error; loc = _position; message = "Missing operator before text" } + let test = ( "Syntax Errors", [ @@ -295,4 +313,6 @@ let test = Alcotest.test_case "act: else" `Quick unclosed_act; Alcotest.test_case "+ =" `Quick unknown_operator; Alcotest.test_case "'<<''>>'" `Quick nested_string_mess; + Alcotest.test_case "a[]]" `Quick unexpected_bracket; + Alcotest.test_case "Missing +" `Quick missing_operator; ] ) diff --git a/test/type_of.ml b/test/type_of.ml index e816bc7..1b84faa 100644 --- a/test/type_of.ml +++ b/test/type_of.ml @@ -78,7 +78,7 @@ let concat_text () = _test_instruction {|$a = 'A' + 1|} [] let increment_string () = _test_instruction {|$a += 1|} (message' Error) let test = - ( "Typechecking", + ( __FILE__, [ Alcotest.test_case "Assign str to int" `Quick type_mismatch; Alcotest.test_case "$str = int" `Quick assign_int_str; |