From 53c02501935b3cb2db78e79deb4d38c997505a95 Mon Sep 17 00:00:00 2001 From: Chimrod <> Date: Mon, 2 Dec 2024 09:05:18 +0100 Subject: Moved the checks in a dedicated library --- lib/checks/check.ml | 433 +++++++++++++++++++++++++++++++++++++ lib/checks/check.mli | 69 ++++++ lib/checks/compose.ml | 127 +++++++++++ lib/checks/dead_end.ml | 174 +++++++++++++++ lib/checks/dead_end.mli | 6 + lib/checks/default.ml | 45 ++++ lib/checks/dune | 9 + lib/checks/dup_test.ml | 192 +++++++++++++++++ lib/checks/dup_test.mli | 1 + lib/checks/get_type.ml | 124 +++++++++++ lib/checks/locations.ml | 162 ++++++++++++++ lib/checks/nested_strings.ml | 159 ++++++++++++++ lib/checks/nested_strings.mli | 1 + lib/checks/type_of.ml | 491 ++++++++++++++++++++++++++++++++++++++++++ lib/checks/type_of.mli | 7 + lib/checks/write_only.ml | 220 +++++++++++++++++++ lib/syntax/check.ml | 429 ------------------------------------ lib/syntax/check.mli | 53 ----- lib/syntax/compose.ml | 125 ----------- lib/syntax/dead_end.ml | 171 --------------- lib/syntax/dead_end.mli | 6 - lib/syntax/default.ml | 41 ---- lib/syntax/dup_test.ml | 188 ---------------- lib/syntax/dup_test.mli | 1 - lib/syntax/get_type.ml | 121 ----------- lib/syntax/locations.ml | 159 -------------- lib/syntax/nested_strings.ml | 156 -------------- lib/syntax/nested_strings.mli | 1 - lib/syntax/type_of.ml | 488 ----------------------------------------- lib/syntax/type_of.mli | 7 - lib/syntax/write_only.ml | 217 ------------------- 31 files changed, 2220 insertions(+), 2163 deletions(-) create mode 100644 lib/checks/check.ml create mode 100644 lib/checks/check.mli create mode 100644 lib/checks/compose.ml create mode 100644 lib/checks/dead_end.ml create mode 100644 lib/checks/dead_end.mli create mode 100644 lib/checks/default.ml create mode 100644 lib/checks/dune create mode 100644 lib/checks/dup_test.ml create mode 100644 lib/checks/dup_test.mli create mode 100644 lib/checks/get_type.ml create mode 100644 lib/checks/locations.ml create mode 100644 lib/checks/nested_strings.ml create mode 100644 lib/checks/nested_strings.mli create mode 100644 lib/checks/type_of.ml create mode 100644 lib/checks/type_of.mli create mode 100644 lib/checks/write_only.ml delete mode 100644 lib/syntax/check.ml delete mode 100644 lib/syntax/check.mli delete mode 100644 lib/syntax/compose.ml delete mode 100644 lib/syntax/dead_end.ml delete mode 100644 lib/syntax/dead_end.mli delete mode 100644 lib/syntax/default.ml delete mode 100644 lib/syntax/dup_test.ml delete mode 100644 lib/syntax/dup_test.mli delete mode 100644 lib/syntax/get_type.ml delete mode 100644 lib/syntax/locations.ml delete mode 100644 lib/syntax/nested_strings.ml delete mode 100644 lib/syntax/nested_strings.mli delete mode 100644 lib/syntax/type_of.ml delete mode 100644 lib/syntax/type_of.mli delete mode 100644 lib/syntax/write_only.ml (limited to 'lib') diff --git a/lib/checks/check.ml b/lib/checks/check.ml new file mode 100644 index 0000000..76d5c34 --- /dev/null +++ b/lib/checks/check.ml @@ -0,0 +1,433 @@ +module Id = Type.Id + +(** The the Id module, wrap a value in an existencial type with a witness + associate with. *) +type result = R : { value : 'a; witness : 'a Id.t } -> result + +let get : type a. a Id.t -> result -> a option = + fun typeid (R { value; witness }) -> + match Id.provably_equal typeid witness with + | Some Type.Equal -> Some value + | None -> None + +type t = + | E : { + module_ : + (module Qsp_syntax.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 Id.t; + expr' : 'b Id.t; + instr_witness : 'c Id.t; + instr' : 'd Id.t; + location_witness : 'e Id.t; + context : 'f Id.t; + } + -> t + +let build : + (module Qsp_syntax.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 Id.t * t = + fun module_ -> + let expr_witness = Id.make () + and expr' = Id.make () + and instr_witness = Id.make () + and instr' = Id.make () + and location_witness = Id.make () + and context = Id.make () in + let t = + E + { + module_; + expr_witness; + expr'; + instr_witness; + instr'; + location_witness; + context; + } + in + (location_witness, t) + +let get_module : t -> (module Qsp_syntax.S.Analyzer) = + fun (E { module_; _ }) -> (module_ :> (module Qsp_syntax.S.Analyzer)) + +module type App = sig + val t : t array +end + +open StdLabels + +module Helper = struct + type 'a expr_list = { witness : 'a Id.t; values : 'a list } + + let expr_i : result array list -> 'a Id.t -> int -> 'a expr_list = + fun args witness i -> + let result = + List.fold_left args ~init:{ values = []; witness } + ~f:(fun (type a) ({ values; witness } : a expr_list) t : a expr_list -> + match get witness (Array.get t i) with + | None -> failwith "Does not match" + | Some value_1 -> { values = value_1 :: values; witness }) + in + { result with values = result.values } +end + +module Make (A : App) = struct + let identifier = "main_checker" + let description = "Internal module" + let is_global = false + let active = ref false + + 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 each test, and keep the result in the context. *) + let initialize : unit -> context = + fun () -> + Array.map A.t ~f:(fun (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) (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 + (i + 1, List.rev_append reports acc)) + in + report + + (* Global variable for the whole module *) + let len = Array.length A.t + + module Expression : Qsp_syntax.S.Expression with type t' = result array = + struct + type t = result array + type t' = result array + + let literal : Qsp_syntax.S.pos -> t Qsp_syntax.T.literal list -> t = + fun pos values -> + Array.mapi A.t ~f:(fun i (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 : Qsp_syntax.S.pos -> string -> t = + fun pos value -> + Array.map A.t ~f:(fun (E { module_ = (module S); expr_witness; _ }) -> + let value = S.Expression.integer pos value in + R { value; witness = expr_witness }) + + (** Unary operator like [-123] or [+'Text']*) + let uoperator : Qsp_syntax.S.pos -> Qsp_syntax.T.uoperator -> t -> t = + fun pos op values -> + (* Evaluate the nested expression *) + let results = values in + + (* Now evaluate the remaining expression. + + Traverse both the module the apply, and the matching expression already + evaluated. + + 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 (E { module_ = (module S); expr_witness; _ }) value -> + 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 }) + in + results + + (** Basically the same as uoperator, but operate over two operands instead + of a single one. *) + let boperator : Qsp_syntax.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") + + (** Call a function. The functions list is hardcoded in lib/lexer.mll *) + let function_ : Qsp_syntax.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 : (Qsp_syntax.S.pos, t) Qsp_syntax.S.variable -> t = + fun { pos : Qsp_syntax.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 })) + + (** Convert each internal represention for the expression into its external + representation *) + let v : t -> t' = + fun t -> + let result = + Array.map2 A.t t + ~f:(fun (E { module_ = (module S); expr_witness; expr'; _ }) result -> + match get expr_witness result with + | None -> failwith "Does not match" + | Some value -> + let value = S.Expression.v value in + R { witness = expr'; value }) + in + result + end + + module Instruction : + Qsp_syntax.S.Instruction + with type expression = Expression.t' + and type t' = result array = struct + type expression = Expression.t' + type t = result array + type t' = result array + + let location : Qsp_syntax.S.pos -> string -> t = + fun pos label -> + Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) -> + let value = S.Instruction.location pos label in + R { value; witness = instr_witness }) + + let comment : Qsp_syntax.S.pos -> t = + fun pos -> + Array.map A.t ~f:(fun (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 + ~f:(fun (E { module_ = (module S); instr_witness; expr'; _ }) result -> + match get expr' result with + | None -> failwith "Does not match" + | Some value -> + (* The evaluate the instruction *) + let value = S.Instruction.expression value in + R { value; witness = instr_witness }) + + let call : Qsp_syntax.S.pos -> Qsp_syntax.T.keywords -> expression list -> t + = + fun pos keyword args -> + (* The arguments are given like an array of array. Each expression is + 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 + in + + let values = List.rev (Helper.expr_i args expr' i).values in + + let value = S.Instruction.call pos keyword values in + R { witness = instr_witness; value }) + + let act : Qsp_syntax.S.pos -> label:expression -> t list -> t = + fun pos ~label instructions -> + Array.init len ~f:(fun i -> + let (E { module_ = (module S); instr_witness; expr'; _ }) = + Array.get A.t i + in + let values = + List.rev (Helper.expr_i instructions instr_witness i).values + in + + match get expr' (Array.get label i) with + | None -> failwith "Does not match" + | Some label_i -> + let value = S.Instruction.act pos ~label:label_i values in + R { witness = instr_witness; value }) + + (* I think it’s one of the longest module I’ve ever written in OCaml… *) + + let assign : + Qsp_syntax.S.pos -> + (Qsp_syntax.S.pos, expression) Qsp_syntax.S.variable -> + Qsp_syntax.T.assignation_operator -> + expression -> + t = + 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 + in + + let index_i = + Option.map + (fun expression -> + Option.get (get expr' (Array.get expression i))) + index + in + let variable = + Qsp_syntax.S.{ pos = var_pos; name; index = index_i } + in + + match get expr' (Array.get expression i) with + | None -> failwith "Does not match" + | Some value -> + let value = A.Instruction.assign pos variable op value in + + R { value; witness = instr_witness }) + + let rebuild_clause : + type a b. + int -> + a Id.t -> + b Id.t -> + Qsp_syntax.S.pos * result array * result array list -> + (b, a) Qsp_syntax.S.clause = + fun i instr_witness expr' clause -> + let pos_clause, expr_clause, ts = clause in + match get expr' (Array.get expr_clause i) with + | None -> failwith "Does not match" + | Some value -> + let ts = Helper.expr_i ts instr_witness i in + let ts = List.rev ts.values in + let clause = (pos_clause, value, ts) in + clause + + let if_ : + Qsp_syntax.S.pos -> + (expression, t) Qsp_syntax.S.clause -> + elifs:(expression, t) Qsp_syntax.S.clause list -> + else_:(Qsp_syntax.S.pos * t list) option -> + t = + fun pos clause ~elifs ~else_ -> + (* First, apply the report for all the instructions *) + let else_ = + match else_ with + | None -> None + | Some (pos, instructions) -> Some (pos, instructions) + in + Array.init len ~f:(fun i -> + let (E { module_ = (module A); instr_witness; expr'; _ }) = + Array.get A.t i + in + + let clause = rebuild_clause i instr_witness expr' clause + and elifs = List.map elifs ~f:(rebuild_clause i instr_witness expr') + and else_ = + match else_ with + | None -> None + | Some (pos, instructions) -> + let elses = Helper.expr_i instructions instr_witness i in + Some (pos, List.rev elses.values) + in + + let value = A.Instruction.if_ pos clause ~elifs ~else_ in + R { value; witness = instr_witness }) + + (** This code is almost a copy/paste from Expression.v but I did not found + a way to factorize it. *) + let v : t -> t' = + fun t -> + let result = + Array.map2 A.t t + ~f:(fun + (E { module_ = (module S); instr_witness; instr'; _ }) result -> + match get instr_witness result with + | None -> failwith "Does not match" + | Some value -> + let value = S.Instruction.v value in + R { witness = instr'; value }) + in + result + end + + module Location : + Qsp_syntax.S.Location + with type t = result array + and type instruction = Instruction.t' + and type context := context = struct + type instruction = Instruction.t' + type t = result array + + let location : context -> Qsp_syntax.S.pos -> instruction list -> t = + fun local_context pos args -> + ignore pos; + + let result = + Array.init len ~f:(fun i -> + let (E + { module_ = (module A); instr'; location_witness; context; _ }) + = + Array.get A.t i + in + + let local_context = + Option.get (get context (Array.get local_context i)) + in + + let instructions = List.rev (Helper.expr_i args instr' i).values in + let value = A.Location.location local_context pos instructions in + R { value; witness = location_witness }) + in + result + + let v : t -> Qsp_syntax.Report.t list = + fun args -> + let report = ref [] in + let () = + Array.iteri args ~f:(fun i result -> + let (E { module_ = (module A); location_witness; _ }) = + Array.get A.t i + in + match get location_witness result with + | None -> failwith "Does not match" + | Some value -> + let re = A.Location.v value in + report := List.rev_append re !report) + in + !report + end +end diff --git a/lib/checks/check.mli b/lib/checks/check.mli new file mode 100644 index 0000000..321b67b --- /dev/null +++ b/lib/checks/check.mli @@ -0,0 +1,69 @@ +(** This module is a meta-checker. It will take many checkers and aggregate + their result together before providing an unified result. + + The modules required to be declared before being used, using the [build] + method, and provided as an array : + + {[ + let _, e1 = build (module …) + let _, e2 = build (module …) + + module Check = Make (struct + let t = [| e1; e2 |] + end) + ]} +*) + +module Id : sig + type 'a t + (** The type created on-the-fly. *) +end + +type t = + | E : { + module_ : + (module Qsp_syntax.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 Id.t; + expr' : 'b Id.t; + instr_witness : 'c Id.t; + instr' : 'd Id.t; + location_witness : 'e Id.t; + context : 'f Id.t; + } + -> t (** Type of check to apply *) + +val build : + (module Qsp_syntax.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 Id.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 Qsp_syntax.S.Analyzer) + +type result + +val get : 'a Id.t -> result -> 'a option +(** The method [get] can be used to get the internal value for one of the + checker used. + *) + +module Make (A : sig + val t : t array +end) : sig + include Qsp_syntax.S.Analyzer with type Location.t = result array +end +[@@warning "-67"] diff --git a/lib/checks/compose.ml b/lib/checks/compose.ml new file mode 100644 index 0000000..4517755 --- /dev/null +++ b/lib/checks/compose.ml @@ -0,0 +1,127 @@ +(** 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 new file mode 100644 index 0000000..629a966 --- /dev/null +++ b/lib/checks/dead_end.ml @@ -0,0 +1,174 @@ +open StdLabels +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report + +let identifier = "dead_end" +let description = "Check for dead end in the code" +let is_global = false +let active = ref false + +type context = unit + +let initialize = Fun.id +let finalize () = [] + +module Expression = struct + type t = unit + + include Default.Expression (struct + type nonrec t = t + + let default = () + end) + + let v : t -> t' = fun () -> () +end + +module Instruction = struct + type cause = Missing_else | Unchecked_path + + type state = { + block_pos : S.pos; + has_gt : bool; + is_gt : bool; + pos : (cause * S.pos) option; + } + + type t = state + type t' = state + + (** For each instruction, return thoses two informations : + + - the intruction contains at [gt] + - the last instruction is a [gt] + + *) + let v : t -> t' = fun t -> t + + let default = + { + block_pos = (Lexing.dummy_pos, Lexing.dummy_pos); + has_gt = false; + is_gt = false; + pos = None; + } + + (** Call for an instruction like [GT] or [*CLR] *) + let call : S.pos -> T.keywords -> Expression.t' list -> t = + fun pos f _ -> + ignore pos; + match f with + | T.Goto | T.XGoto -> + { block_pos = pos; has_gt = true; is_gt = true; pos = None } + | T.Gosub -> { block_pos = pos; has_gt = false; is_gt = true; pos = None } + | _ -> default + + (** Label for a loop *) + let location : S.pos -> string -> t = fun _ _ -> default + + (** Comment *) + let comment : S.pos -> t = fun _ -> default + + (** 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 *) + let check_block : S.pos -> t list -> t = + fun pos instructions -> + let last_element = + List.fold_left instructions ~init:default ~f:(fun t instruction -> + let result = instruction in + let has_gt = result.has_gt || t.has_gt in + let is_gt = result.is_gt || t.is_gt in + { result with block_pos = pos; is_gt; has_gt }) + in + last_element + + let if_ : + S.pos -> + (Expression.t', t) S.clause -> + elifs:(Expression.t', t) S.clause list -> + else_:(S.pos * t list) option -> + t = + fun pos clause ~elifs ~else_ -> + (* For each block, evaluate the instructions *) + let res, has_gt, is_gt = + List.fold_left ~init:([], false, false) (clause :: elifs) + ~f:(fun (acc, has_gt, is_gt) clause -> + let pos, _, instructions = clause in + let clause_t = check_block pos instructions in + let has_gt = has_gt || clause_t.has_gt + and is_gt = is_gt || clause_t.is_gt in + + ((clause_t, pos) :: acc, has_gt, is_gt)) + in + + let else_pos, else_block = + match else_ with + | Some (pos, instructions) -> + let block = check_block pos instructions in + (pos, block) + | None -> (pos, default) + in + let has_gt = has_gt || else_block.has_gt + and is_gt = is_gt || else_block.is_gt in + + let blocks = (else_block, else_pos) :: res in + + (* Check if one of the clauses already holds a dead end*) + match List.find_opt res ~f:(fun (res, _) -> res.pos != None) with + | Some (v, _) -> v + | None -> ( + match (is_gt, has_gt) with + | _, true -> ( + (* There is gt intruction in one of the branch, we need to checks + the others *) + match List.find_opt blocks ~f:(fun (f, _) -> not f.is_gt) with + | None -> + (* Every branch in the if is covered. It’s ok. *) + { default with block_pos = pos; is_gt; has_gt } + | Some (_, pos) -> + (* TODO check if [pos] is the whole block *) + let cause = + match else_ with None -> Missing_else | _ -> Unchecked_path + in + { default with block_pos = pos; pos = Some (cause, pos) }) + | _, _ -> { default with block_pos = pos; has_gt; is_gt }) + + let act : S.pos -> label:Expression.t' -> t list -> t = + fun pos ~label expressions -> + ignore label; + check_block pos expressions + + let assign : + S.pos -> + (S.pos, Expression.t') S.variable -> + T.assignation_operator -> + Expression.t' -> + t = + fun _ _ _ _ -> default +end + +module Location = struct + type t = Report.t list + + let v = Fun.id + + let location : unit -> S.pos -> Instruction.t' list -> t = + fun () _pos instructions -> + List.fold_left instructions ~init:[] ~f:(fun report t -> + match (t.Instruction.is_gt, t.Instruction.pos) with + | false, Some (cause, value) -> + ignore cause; + if t.Instruction.block_pos != value then + match cause with + | Missing_else -> + Report.debug value "Possible dead end (no else fallback)" + :: report + | Unchecked_path -> + Report.warn value "Possible dead end (unmatched path)" + :: report + else report + | _ -> report) +end diff --git a/lib/checks/dead_end.mli b/lib/checks/dead_end.mli new file mode 100644 index 0000000..d8fe7d6 --- /dev/null +++ b/lib/checks/dead_end.mli @@ -0,0 +1,6 @@ +(** Checker looking for the dead ends in the source. + + A dead end is a state where the user does not have any action. + *) + +include Qsp_syntax.S.Analyzer diff --git a/lib/checks/default.ml b/lib/checks/default.ml new file mode 100644 index 0000000..a2b53f6 --- /dev/null +++ b/lib/checks/default.ml @@ -0,0 +1,45 @@ +(** 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. *) + +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report + +module type 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 + index. + + 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 + + (* + 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 + + (** 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 + + (** Unary operator like [-123] or [+'Text']*) + let uoperator : S.pos -> T.uoperator -> T'.t -> T'.t = fun _ _ _ -> 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 +end diff --git a/lib/checks/dune b/lib/checks/dune new file mode 100644 index 0000000..d7db2f3 --- /dev/null +++ b/lib/checks/dune @@ -0,0 +1,9 @@ +(library + (name qsp_checks) + (libraries + qsp_syntax + ) + + (preprocess (pps + ppx_deriving.show ppx_deriving.enum + ppx_deriving.eq ))) diff --git a/lib/checks/dup_test.ml b/lib/checks/dup_test.ml new file mode 100644 index 0000000..e392445 --- /dev/null +++ b/lib/checks/dup_test.ml @@ -0,0 +1,192 @@ +(** 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. + *) + +open StdLabels +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report +module Tree = Qsp_syntax.Tree + +let identifier = "duplicate_test" +let description = "Check for duplicate tests" +let is_global = false +let active = ref true + +type context = unit + +let initialize = Fun.id +let finalize () = [] + +module Expression = Tree.Expression + +(** Build a Hashtbl over the expression, ignoring the location in the + expression *) +module Table = Hashtbl.Make (struct + type t = Expression.t' + + let equal : t -> t -> bool = Tree.Expression.eq (fun _ _ -> true) + let hash : t -> int = Tree.Expression.hash (fun _ -> 0) +end) + +module Instruction = struct + type state = { + 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. *) + + 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 + + (** Comment *) + let comment : S.pos -> t = fun _ -> default + + (** Raw expression *) + let expression : Expression.t' -> t = fun _ -> default + + let check_duplicates : + (Expression.t' * S.pos) list -> (Expression.t' * S.pos list) list = + fun predicates -> + let table = Table.create 5 in + let () = List.to_seq predicates |> Table.add_seq table in + + Table.to_seq_keys table + |> Seq.group (Tree.Expression.eq (fun _ _ -> true)) + |> Seq.filter_map (fun keys -> + (* Only take the first element for each group, we don’t need to + repeat the key *) + match Seq.uncons keys with + | None -> None + | Some (hd, _) -> ( + match Table.find_all table hd with + | [] | _ :: [] -> None + | 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 *) + let predicate_of_clause : ?pos:S.pos -> t -> (Expression.t', t) S.clause -> t + = + fun ?pos t (pos2, predicate, blocks) -> + let pos = Option.value ~default:pos2 pos in + + (* Remove the clauses using the function rnd because they repeating the + same clause can generate a different result *) + let should_discard = + Tree.Expression.exists predicate ~f:(function + | Tree.Ast.Function (_, T.Rand, _) | Tree.Ast.Function (_, T.Rnd, _) -> + true + | _ -> false) + in + + { + predicates = + (match should_discard with + | false -> (predicate, pos) :: t.predicates + | true -> t.predicates); + duplicates = + List.fold_left blocks ~init:t.duplicates ~f:(fun acc t -> + List.rev_append t.duplicates acc); + } + + let if_ : + S.pos -> + (Expression.t', t) S.clause -> + elifs:(Expression.t', t) S.clause list -> + else_:(S.pos * t list) option -> + t = + fun pos clause ~elifs ~else_ -> + ignore else_; + (* Collect all the if clauses from this block, wait for the parent block to + check each case for duplicates. *) + let init = predicate_of_clause ~pos default clause in + let state = List.fold_left elifs ~init ~f:predicate_of_clause in + { + 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 + type t = (Expression.t' * S.pos list) list + + type context = unit + (** No context *) + + (** Check if the given expression is involving the variable ARGS or $ARGS *) + let is_args : Expression.t' -> bool = function + | Tree.Ast.Ident { name; _ } -> + String.equal name "ARGS" || String.equal name "$ARGS" + | _ -> false + + let location : context -> S.pos -> Instruction.t' list -> t = + fun () _ block -> + (* Filter the tests from the top level and only keep them testing ARGS *) + let duplicates = + List.map block ~f:(fun t -> + List.filter_map t.Instruction.predicates ~f:(fun v -> + match (Tree.Expression.exists ~f:is_args) (fst v) with + | true -> Some v + | false -> None)) + |> List.concat |> Instruction.check_duplicates + in + List.fold_left ~init:duplicates block ~f:(fun state ex -> + List.rev_append ex.Instruction.duplicates state) + + (** Create the report message *) + let v' : Expression.t' * S.pos list -> Report.t option = + fun (expr, pos) -> + ignore expr; + match (List.sort ~cmp:Report.compare_pos) pos with + | [] -> None + | _ :: [] -> None + | hd :: tl -> + let message = + Format.asprintf "This case is duplicated line(s) %a" + (Format.pp_print_list + ~pp_sep:(fun f () -> Format.pp_print_char f ',') + Report.pp_line) + tl + in + + (* Report all the messages as error. They do not break the game, but + there is no question if it should *) + Some (Report.error hd message) + + let v : t -> Report.t list = + fun t -> List.filter_map t ~f:v' |> List.sort_uniq ~cmp:Report.compare +end diff --git a/lib/checks/dup_test.mli b/lib/checks/dup_test.mli new file mode 100644 index 0000000..6446c67 --- /dev/null +++ b/lib/checks/dup_test.mli @@ -0,0 +1 @@ +include Qsp_syntax.S.Analyzer diff --git a/lib/checks/get_type.ml b/lib/checks/get_type.ml new file mode 100644 index 0000000..b34dc17 --- /dev/null +++ b/lib/checks/get_type.ml @@ -0,0 +1,124 @@ +open StdLabels +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report + +type type_of = + | Integer (** A numeric value *) + | Bool (** A boolean, not a real type *) + | String (** String value *) + | NumericString + [@printer fun fmt _ -> Format.pp_print_string fmt "Integer as String"] + (** 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 + 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' -> ( + try List.hd params with Failure _ -> Raw Bool) + | 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 diff --git a/lib/checks/locations.ml b/lib/checks/locations.ml new file mode 100644 index 0000000..8ee6ffa --- /dev/null +++ b/lib/checks/locations.ml @@ -0,0 +1,162 @@ +open StdLabels +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report + +module IgnoreCaseString = struct + type t = string + + let compare t1 t2 = + String.compare (String.lowercase_ascii t1) (String.lowercase_ascii t2) + + let equal t1 t2 = + String.equal (String.lowercase_ascii t1) (String.lowercase_ascii t2) +end + +module LocationSet = Set.Make (IgnoreCaseString) +module LocationCalls = Map.Make (IgnoreCaseString) + +let identifier = "locations" +let description = "Ensure every call points to an existing location" +let is_global = true +let active = ref true + +type t = { + locations : LocationSet.t; + calls : (string * S.pos) list LocationCalls.t; +} + +type context = t ref + +let initialize () = + ref { locations = LocationSet.empty; calls = LocationCalls.empty } + +let finalize : context -> (string * Report.t) list = + fun context -> + LocationCalls.fold + (fun location positions acc -> + let message = Printf.sprintf "The location %s does not exists" location in + + List.fold_left ~init:acc (List.rev positions) + ~f:(fun acc (loc, position) -> + let report = Report.error position message in + (loc, report) :: acc)) + !context.calls [] + +(** Register a new call to a defined location. *) +let registerCall : S.pos -> string -> t -> t = + fun pos location t -> + let file_name = (fst pos).Lexing.pos_fname in + match + IgnoreCaseString.equal location file_name + || LocationSet.mem location t.locations + with + | true -> t + | false -> + (* The location is not yet defined, register the call for later *) + let calls = + LocationCalls.update location + (function + | None -> Some [ (file_name, pos) ] + | Some poss -> + Some + (let new_pos = (file_name, pos) in + new_pos :: poss)) + t.calls + in + { t with calls } + +(** Add a new location in the list of all the collected elements *) +let registerLocation : string -> t -> t = + fun location t -> + let calls = LocationCalls.remove location t.calls + and locations = LocationSet.add location t.locations in + { calls; locations } + +(** The module Expression is pretty simple, we are only interrested by the + strings ( because only the first argument of [gt …] is read ). + + If the string is too much complex, we just ignore it. *) +module Expression = struct + type t = string option + + include Default.Expression (struct + type nonrec t = t + + let default = None + end) + + 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 +end + +module Instruction = struct + type nonrec t = t -> t + type t' = t + + let v : t -> t' = Fun.id + + (** Keep a track of every gt or gs instruction *) + let call : S.pos -> T.keywords -> Expression.t' list -> t = + fun pos fn args t -> + match (fn, args) with + | 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 + type t = unit + + let v : t -> Report.t list = fun () -> [] + + let location : context -> S.pos -> Instruction.t list -> t = + fun context pos instructions -> + (* Register the location *) + let file_name = (fst pos).Lexing.pos_fname in + let c = registerLocation file_name !context in + (* Then update the list of all the calls to the differents locations *) + context := + List.fold_left instructions ~init:c ~f:(fun t instruction -> + instruction t) +end diff --git a/lib/checks/nested_strings.ml b/lib/checks/nested_strings.ml new file mode 100644 index 0000000..e4ffb68 --- /dev/null +++ b/lib/checks/nested_strings.ml @@ -0,0 +1,159 @@ +open StdLabels +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report + +let identifier = "escaped_string" +let description = "Check for unnecessary use of expression encoded in string" +let is_global = false +let active = ref true + +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 + type t' = Report.t list + + let v : Get_type.t Lazy.t * t -> t' = snd + + (** Identify the expressions reprented as string. That’s here that the report + 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 -> + match content with + | [ T.Expression (t', _); T.Text "" ] -> ( + match Get_type.get_type (Lazy.force t') with + | Get_type.Integer -> [] + | _ -> + let msg = Report.debug pos "This expression can be simplified" in + [ msg ]) + | _ -> [] + + 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 integer : S.pos -> string -> Get_type.t Lazy.t -> t = + fun pos t _type_of -> + ignore pos; + ignore t; + [] + + 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 -> + ignore pos; + ignore f; + let exprs = + List.fold_left ~init:[] expressions ~f:(fun acc el -> + List.rev_append (snd el) acc) + in + 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 -> + ignore op; + ignore pos; + snd r + + 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 -> + ignore pos; + ignore op; + r1 @ r2 +end) + +module Instruction : + S.Instruction with type t' = Report.t list and type expression = Expression.t' = +struct + type t = Report.t list + (** Internal type used in the evaluation *) + + type t' = t + + let v : t -> t' = Fun.id + + type expression = Expression.t' + + let call : S.pos -> T.keywords -> expression list -> t = + fun pos k exprs -> + ignore pos; + ignore k; + List.concat exprs + + let location : S.pos -> string -> t = fun _ _ -> [] + let comment : S.pos -> t = fun _ -> [] + let expression : expression -> t = Fun.id + + let act : S.pos -> label:expression -> t list -> t = + fun pos ~label instructions -> + ignore pos; + List.concat (label :: instructions) + + let fold_clause : (expression, t) S.clause -> t = + fun (_pos1, expression, ts) -> List.concat (expression :: ts) + + let if_ : + S.pos -> + (expression, t) S.clause -> + elifs:(expression, t) S.clause list -> + else_:(S.pos * t list) option -> + t = + fun pos clause ~elifs ~else_ -> + ignore pos; + + let init = + match else_ with + | None -> fold_clause clause + | Some (_, ts) -> List.rev_append (fold_clause clause) (List.concat ts) + in + + List.fold_left elifs ~init ~f:(fun t clause -> + List.rev_append (fold_clause clause) t) + + let assign : + S.pos -> + (S.pos, expression) S.variable -> + T.assignation_operator -> + expression -> + t = + fun pos variable op expression -> + ignore pos; + ignore op; + match variable.index with + | None -> expression + | Some v -> List.rev_append v expression +end + +module Location = struct + type t = Report.t list + type instruction = Instruction.t' + + let v = Fun.id + + let location : unit -> S.pos -> instruction list -> t = + fun () pos intructions -> + ignore pos; + List.concat intructions +end diff --git a/lib/checks/nested_strings.mli b/lib/checks/nested_strings.mli new file mode 100644 index 0000000..6446c67 --- /dev/null +++ b/lib/checks/nested_strings.mli @@ -0,0 +1 @@ +include Qsp_syntax.S.Analyzer diff --git a/lib/checks/type_of.ml b/lib/checks/type_of.ml new file mode 100644 index 0000000..70ae324 --- /dev/null +++ b/lib/checks/type_of.ml @@ -0,0 +1,491 @@ +open StdLabels +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report + +let identifier = "type_check" +let description = "Ensure all the expression are correctly typed" +let is_global = false +let active = ref true + +type context = unit + +let initialize = Fun.id +let finalize () = [] + +module Helper = struct + type argument_repr = { pos : S.pos; t : Get_type.t } + + module DynType = struct + type nonrec t = Get_type.t -> Get_type.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.*) + + (** Build a new dynamic type *) + let t : unit -> t = + fun () -> + let stored = ref None in + fun t -> + match !stored with + | None -> + stored := Some t; + t + | Some t -> t + end + + (** 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. *) + type argument = + | Fixed of Get_type.type_of + | Dynamic of DynType.t + | Variable of argument + + let compare : + ?level:Report.level -> + strict:bool -> + Get_type.type_of -> + argument_repr -> + Report.t list -> + Report.t list = + fun ?(level = Report.Warn) ~strict expected actual report -> + let equal = + match (expected, actual.t) with + (* Strict equality for this ones, always true *) + | String, Variable String + | String, Raw String + | String, Variable NumericString + | String, Raw NumericString + | Integer, Variable Integer + | Integer, Raw Integer + | NumericString, Variable NumericString + | NumericString, Raw NumericString + | Bool, Raw Bool + | Bool, Variable Bool + (* Also include the conversion between bool and integer *) + | Integer, Raw Bool + | Integer, Variable Bool + (* The type NumericString can be used as a generic type in input *) + | _, Variable NumericString + | NumericString, Raw String + | NumericString, Variable String + | NumericString, Raw Integer + | NumericString, Variable Integer -> + true + | Bool, Variable Integer + | Bool, Raw Integer + | String, Variable Integer + | String, Raw Bool + | String, Variable Bool + | Integer, Variable String + | Integer, Raw NumericString -> + not strict + (* Explicit rejected cases *) + | String, Raw Integer | Integer, Raw String -> false + | _, _ -> false + in + if equal then report + else + let result_type = match actual.t with Variable v -> v | Raw r -> r in + let message = + Format.asprintf "The type %a is expected but got %a" Get_type.pp_type_of + expected Get_type.pp_type_of result_type + in + Report.message level actual.pos message :: report + + let rec compare_parameter : + strict:bool -> + ?level:Report.level -> + argument -> + argument_repr -> + Report.t list -> + Report.t list = + fun ~strict ?(level = Report.Warn) expected param report -> + match expected with + | Fixed t -> compare ~strict ~level t param report + | Dynamic d -> + let type_ = match d param.t with Raw r -> r | Variable v -> v in + compare ~strict ~level type_ param report + | Variable c -> compare_parameter ~level ~strict c param report + + (** Compare the arguments one by one *) + let compare_args : + ?strict:bool -> + ?level:Report.level -> + S.pos -> + argument list -> + argument_repr list -> + Report.t list -> + Report.t list = + fun ?(strict = false) ?(level = Report.Warn) pos expected actuals report -> + let tl, report = + List.fold_left actuals ~init:(expected, report) + ~f:(fun (expected, report) param -> + match expected with + | (Variable _ as hd) :: _ -> + let check = compare_parameter ~strict ~level hd param report in + (expected, check) + | hd :: tl -> + let check = compare_parameter ~strict ~level hd param report in + (tl, check) + | [] -> + let msg = Report.error param.pos "Unexpected argument" in + ([], msg :: report)) + in + match tl with + | [] | Variable _ :: _ -> report + | _ -> + let msg = Report.error pos "Not enougth arguments given" in + msg :: report +end + +module TypeBuilder = Compose.Expression (Get_type) + +type t' = { result : Get_type.t Lazy.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 } + +module TypedExpression = struct + type nonrec t' = t' * Report.t list + type state = { pos : S.pos } + 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) + + (** 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 -> + (* Extract the error from the index *) + let report = + match var.index with + | None -> [] + | Some (_, expr) -> + let _, r = expr in + r + in + ({ pos = var.pos }, report) + + let integer : S.pos -> string -> Get_type.t Lazy.t -> t = + fun pos value _type_of -> + let int_value = int_of_string_opt value in + + let report = + match int_value with + | Some 0 -> [] + | Some _ -> [] + | None -> Report.error pos "Invalid integer value" :: [] + in + + ({ pos }, 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; + let init = [] in + let report = + List.fold_left values ~init ~f:(fun report -> function + | T.Text _ -> report + | T.Expression (_, t) -> + let report = List.rev_append (snd t) report in + report) + in + ({ pos }, 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 -> + (* 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; + let t, r = param in + let arg = arg_of_repr type_of t.pos in + (arg :: types, r @ report)) + in + let types = List.rev types and default = { pos } in + + match function_ with + | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Getobj | Instr + | Isplay -> + (default, report) + | Desc' | Dyneval' | Getobj' -> (default, report) + | Func | Func' -> (default, report) + | Iif | Iif' -> + let d = Helper.DynType.t () in + 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) + | Input | Input' -> + (* Input should check the result if the variable is a num and raise a + message in this case.*) + let expected = Helper.[ Fixed String ] in + let report = Helper.compare_args pos expected types report in + (default, report) + | Isnum -> + let expected = Helper.[ Fixed String ] in + let report = Helper.compare_args pos expected types report in + (default, report) + | Lcase | Lcase' | Ucase | Ucase' -> + let expected = Helper.[ Fixed String ] in + let report = Helper.compare_args pos expected types report in + (default, report) + | Len -> + let expected = Helper.[ Fixed NumericString ] in + let report = Helper.compare_args pos expected types report in + (default, report) + | Loc -> + let expected = Helper.[ Fixed String ] in + let report = Helper.compare_args pos expected types report in + (default, report) + | Max | Max' | Min | Min' -> + let d = Helper.DynType.t () in + (* 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) + | Mid | Mid' -> + let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in + let report = Helper.compare_args pos expected types report in + (default, report) + | Msecscount -> (default, report) + | Rand -> + let expected = Helper.[ Variable (Fixed Integer) ] in + let report = Helper.compare_args pos expected types report in + (default, report) + | Replace -> (default, report) + | Replace' -> (default, report) + | Rgb -> (default, report) + | Rnd -> + (* No arg *) + let report = Helper.compare_args pos [] types report in + (default, report) + | Selact -> (default, report) + | Str | Str' -> + let expected = Helper.[ Variable (Fixed Integer) ] in + let report = Helper.compare_args pos expected types report in + (default, report) + | Strcomp -> (default, report) + | Strfind -> (default, report) + | Strfind' -> (default, report) + | Strpos -> (default, report) + | Trim -> (default, report) + | Trim' -> (default, report) + | Val -> + let expected = Helper.[ Fixed NumericString ] in + let report = Helper.compare_args pos expected types report in + (default, report) + + (** 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 + match operator with + | Add -> (t, report) + | Neg | No -> + let types = [ arg_of_repr type_of t.pos ] in + let expected = Helper.[ Fixed Integer ] in + let report = Helper.compare_args pos expected types report in + ({ pos }, 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; + let t1, report1 = t1 in + let t2, report2 = t2 in + + let report = report1 @ report2 in + + let types = [ arg_of_repr type_1 t1.pos; arg_of_repr type_2 t2.pos ] in + + match operator with + | T.Plus -> + (* We cannot really much here, because the (+) function can be used to + concatenate string or add numbers. + + When concatenating, it’s allowed to add an integer and a number. + *) + ({ pos }, 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 *) + let d = Helper.(Dynamic (DynType.t ())) in + let expected = [ d; d ] in + (* Compare and report as error if the types are incompatible. If no + error is reported, try in strict mode, and report as a warning. *) + let report = + match + Helper.compare_args ~level:Error pos expected (List.rev types) + report + with + | [] -> + Helper.compare_args ~strict:true pos expected (List.rev types) + report + | report -> report + in + ({ pos }, 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) + | 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) +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 + + type expression = Expression.t' + + (** Call for an instruction like [GT] or [*CLR] *) + let call : S.pos -> T.keywords -> expression list -> t = + fun _pos _ expressions -> + List.fold_left expressions ~init:[] ~f:(fun acc a -> + let _, report = a in + (List.rev_append report) acc) + + let location : S.pos -> string -> t = fun _pos _ -> [] + + (** Comment *) + let comment : S.pos -> t = fun _pos -> [] + + (** Raw expression *) + let expression : expression -> t = fun expression -> snd expression + + (** Helper function used in the [if_] function. *) + let fold_clause : t -> (expression, t) S.clause -> t = + fun report (_pos, expr, instructions) -> + let result, r = expr in + + let r2 = + Helper.compare ~strict:false Get_type.Bool + (arg_of_repr result.result result.pos) + [] + in + + List.fold_left instructions + ~init:(r @ r2 @ report) + ~f:(fun acc a -> + let report = a in + (List.rev_append report) acc) + + let if_ : + S.pos -> + (expression, t) S.clause -> + elifs:(expression, t) S.clause list -> + else_:(S.pos * t list) option -> + t = + fun _pos clause ~elifs ~else_ -> + (* Traverse the whole block recursively *) + let report = fold_clause [] clause in + let report = List.fold_left elifs ~f:fold_clause ~init:report in + + match else_ with + | None -> report + | Some (_, instructions) -> + List.fold_left instructions ~init:report ~f:(fun acc a -> + let report = a in + (List.rev_append report) acc) + + let act : S.pos -> label:expression -> t list -> t = + fun _pos ~label instructions -> + let result, report = label in + let report = + Helper.compare ~strict:false Get_type.String + (arg_of_repr result.result result.pos) + report + in + + List.fold_left instructions ~init:report ~f:(fun acc a -> + let report = a in + (List.rev_append report) acc) + + let assign : + S.pos -> + (S.pos, expression) S.variable -> + T.assignation_operator -> + expression -> + t = + fun pos variable op expression -> + let right_expression, report = expression in + + let report' = Option.map snd variable.index |> Option.value ~default:[] in + + let report = List.rev_append report' report in + + match (op, Get_type.get_type (Lazy.force 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 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 op1 = arg_of_repr var_type variable.pos in + let op2 = arg_of_repr right_expression.result right_expression.pos in + + let d = Helper.DynType.t () in + (* Every part of the assignation should be the same type *) + let expected = Helper.[ Dynamic d; Dynamic d ] in + + match + Helper.compare_args ~strict:false ~level:Report.Error pos expected + [ op1; op2 ] [] + with + | [] -> + Helper.compare_args ~strict:true ~level:Report.Warn pos expected + [ op1; op2 ] report + | reports -> reports @ report) +end + +module Location = struct + type t = Report.t list + type instruction = Instruction.t' + + let v = Fun.id + + let location : unit -> S.pos -> instruction list -> t = + fun () _pos instructions -> + let report = + List.fold_left instructions ~init:[] ~f:(fun report instruction -> + let report' = instruction in + report' @ report) + in + report +end diff --git a/lib/checks/type_of.mli b/lib/checks/type_of.mli new file mode 100644 index 0000000..de0f8f9 --- /dev/null +++ b/lib/checks/type_of.mli @@ -0,0 +1,7 @@ +include Qsp_syntax.S.Analyzer +(** The module [type_of] populate the report with differents inconsistency + 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. *) diff --git a/lib/checks/write_only.ml b/lib/checks/write_only.ml new file mode 100644 index 0000000..8363703 --- /dev/null +++ b/lib/checks/write_only.ml @@ -0,0 +1,220 @@ +(** Check all the write_only variables *) + +open StdLabels +module S = Qsp_syntax.S +module T = Qsp_syntax.T +module Report = Qsp_syntax.Report + +(** Identifier for the module *) +let identifier = "write_only" + +(** Short description*) +let description = "Check variables never read" + +(** Is the test active or not *) +let active = ref false + +let is_global = true + +module Key = struct + type t = string + + let equal = String.equal + let hash = Hashtbl.hash + let compare = String.compare +end + +module StringMap = Hashtbl.Make (Key) +module Set = Set.Make (Key) + +type data = { write : bool; read : bool; position : S.pos list } +type context = (string * data) StringMap.t + +let initialize () = StringMap.create 16 + +let keywords = + [ + "BACKIMAGE"; + "$BACKIMAGE"; + "BCOLOR"; + "DEBUG"; + "DISABLESCROLL"; + "DISABLESUBEX"; + "FCOLOR"; + "$FNAME"; + "FSIZE"; + "GC"; + "LCOLOR"; + "NOSAVE"; + ] + |> Set.of_list + +let set_readed : + ?update_only:bool -> S.pos -> string -> string -> context -> unit = + fun ?(update_only = false) pos identifier filename map -> + if not (Set.mem identifier keywords) then + match (update_only, StringMap.find_opt map identifier) with + | false, None -> + StringMap.add map identifier + (filename, { write = false; read = true; position = [] }) + | _, Some (filename, v) -> + StringMap.replace map identifier + (filename, { v with read = true; position = pos :: v.position }) + | true, None -> () + +let set_write : S.pos -> string -> string -> context -> unit = + fun pos identifier filename map -> + if not (Set.mem identifier keywords) then + match StringMap.find_opt map identifier with + | None -> + StringMap.add map identifier + (filename, { write = true; read = false; position = pos :: [] }) + | Some (filename, v) -> + StringMap.replace map identifier + (filename, { v with write = true; position = pos :: v.position }) + +module Expression = struct + type t = string -> context -> unit + + let v : t -> t = Fun.id + + include Default.Expression (struct + type nonrec t = t + + let default _ map = ignore map + end) + + let ident : (S.pos, t) S.variable -> t = + fun variable filename map -> + (* 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 -> + List.iter l ~f:(function + | T.Text t -> + set_readed pos ~update_only:true (String.uppercase_ascii t) filename + map + | T.Expression exprs -> + (* 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 uoperator : S.pos -> T.uoperator -> t -> t = fun _ _ t map -> t map + + let boperator : S.pos -> T.boperator -> t -> t -> t = + fun _ _ t1 t2 filename map -> + t1 filename map; + t2 filename map +end + +module Instruction = struct + type t = Expression.t + (** Internal type used in the evaluation *) + + type t' = t + + let v : t -> t' = Fun.id + + type expression = Expression.t + + let location : S.pos -> string -> t = fun _pos _ _ _ -> () + + let call : S.pos -> T.keywords -> expression list -> t = + fun _ op exprs filename map -> + match op with + | T.KillVar -> + (* Killing a variable does not count as reading it *) + () + | _ -> List.iter ~f:(fun v -> v filename map) exprs + + let comment : S.pos -> t = fun _ _ _ -> () + let expression : expression -> t = fun expression map -> expression map + + let fold_clause : (expression, t) S.clause -> t = + fun clause filename map -> + let _, expr, exprs = clause in + let () = expr filename map in + let () = List.iter ~f:(fun v -> v filename map) exprs in + () + + let if_ : + S.pos -> + (expression, t) S.clause -> + elifs:(expression, t) S.clause list -> + else_:(S.pos * t list) option -> + t = + fun pos clauses ~elifs ~else_ filename map -> + ignore pos; + let () = fold_clause clauses filename map in + let () = List.iter ~f:(fun v -> fold_clause v filename map) elifs in + Option.iter + (fun (_, exprs) -> List.iter exprs ~f:(fun v -> v filename map)) + else_; + () + + let act : S.pos -> label:expression -> t list -> t = + fun pos ~label exprs filename map -> + ignore pos; + ignore label; + List.iter ~f:(fun v -> v filename map) exprs + + let assign : + S.pos -> + (S.pos, expression) S.variable -> + T.assignation_operator -> + expression -> + t = + fun pos variable op expr filename map -> + ignore op; + ignore expr; + Option.iter (fun v -> v filename map) variable.index; + expr filename map; + set_write pos variable.name filename map +end + +module Location = struct + type t = unit + type instruction = string -> context -> unit + + let v : t -> Report.t list = fun _ -> [] + + let location : context -> S.pos -> instruction list -> t = + fun context pos instructions -> + let file_name = (snd pos).Lexing.pos_fname in + ignore pos; + ignore context; + let () = List.iter ~f:(fun v -> v file_name context) instructions in + () +end + +(** Extract the results from the whole parsing *) +let finalize : context -> (string * Report.t) list = + fun map -> + let () = + StringMap.filter_map_inplace + (fun _ (loc, value) -> + match value.read && value.write with + | true -> None + | false -> Some (loc, value)) + map + in + + let report = + StringMap.fold + (fun ident (loc, value) report -> + match value.read with + | false -> + List.fold_left value.position ~init:report ~f:(fun report pos -> + let msg = + Report.debug pos + (String.concat ~sep:" " + [ "The variable"; ident; "is never read" ]) + in + (loc, msg) :: report) + | true -> report) + map [] + in + report diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml deleted file mode 100644 index b642945..0000000 --- a/lib/syntax/check.ml +++ /dev/null @@ -1,429 +0,0 @@ -module Id = Type.Id - -(** The the Id module, wrap a value in an existencial type with a witness - associate with. *) -type result = R : { value : 'a; witness : 'a Id.t } -> result - -let get : type a. a Id.t -> result -> a option = - fun typeid (R { value; witness }) -> - match Id.provably_equal typeid witness with - | Some Type.Equal -> Some value - | None -> None - -type t = - | 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 Id.t; - expr' : 'b Id.t; - instr_witness : 'c Id.t; - instr' : 'd Id.t; - location_witness : 'e Id.t; - context : 'f Id.t; - } - -> t - -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 Id.t * t = - fun module_ -> - let expr_witness = Id.make () - and expr' = Id.make () - and instr_witness = Id.make () - and instr' = Id.make () - and location_witness = Id.make () - and context = Id.make () in - let t = - E - { - module_; - expr_witness; - expr'; - instr_witness; - instr'; - location_witness; - context; - } - in - (location_witness, t) - -let get_module : t -> (module S.Analyzer) = - fun (E { module_; _ }) -> (module_ :> (module S.Analyzer)) - -module type App = sig - val t : t array -end - -open StdLabels - -module Helper = struct - type 'a expr_list = { witness : 'a Id.t; values : 'a list } - - let expr_i : result array list -> 'a Id.t -> int -> 'a expr_list = - fun args witness i -> - let result = - List.fold_left args ~init:{ values = []; witness } - ~f:(fun (type a) ({ values; witness } : a expr_list) t : a expr_list -> - match get witness (Array.get t i) with - | None -> failwith "Does not match" - | Some value_1 -> { values = value_1 :: values; witness }) - in - { result with values = result.values } -end - -module Make (A : App) = struct - let identifier = "main_checker" - let description = "Internal module" - let is_global = false - let active = ref false - - 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 each test, and keep the result in the context. *) - let initialize : unit -> context = - fun () -> - Array.map A.t ~f:(fun (E { module_ = (module S); context; _ }) -> - let value = S.initialize () in - R { value; witness = context }) - - let finalize : result Array.t -> (string * Report.t) list = - fun context_array -> - let _, report = - Array.fold_left A.t ~init:(0, []) - ~f:(fun (i, acc) (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 - (i + 1, List.rev_append reports acc)) - in - report - - (* Global variable for the whole module *) - let len = Array.length A.t - - module Expression : S.Expression with type t' = result array = struct - type t = result array - type t' = result array - - let literal : S.pos -> t T.literal list -> t = - fun pos values -> - Array.mapi A.t ~f:(fun i (E { module_ = (module S); expr_witness; _ }) -> - (* Map every values to the Checker *) - let values' = - List.map values - ~f: - (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 (E { module_ = (module S); expr_witness; _ }) -> - let value = S.Expression.integer pos value in - R { value; witness = expr_witness }) - - (** Unary operator like [-123] or [+'Text']*) - let uoperator : S.pos -> T.uoperator -> t -> t = - fun pos op values -> - (* Evaluate the nested expression *) - let results = values in - - (* Now evaluate the remaining expression. - - Traverse both the module the apply, and the matching expression already - evaluated. - - 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 (E { module_ = (module S); expr_witness; _ }) value -> - 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 }) - in - results - - (** Basically the same as uoperator, but operate over two operands instead - of a single one. *) - let boperator : S.pos -> 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") - - (** Call a function. The functions list is hardcoded in lib/lexer.mll *) - let function_ : S.pos -> 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 })) - - (** Convert each internal represention for the expression into its external - representation *) - let v : t -> t' = - fun t -> - let result = - Array.map2 A.t t - ~f:(fun (E { module_ = (module S); expr_witness; expr'; _ }) result -> - match get expr_witness result with - | None -> failwith "Does not match" - | Some value -> - let value = S.Expression.v value in - R { witness = expr'; value }) - in - result - end - - module Instruction : - S.Instruction - with type expression = Expression.t' - and type t' = result array = struct - type expression = Expression.t' - type t = result array - type t' = result array - - let location : S.pos -> string -> t = - fun pos label -> - Array.map A.t ~f:(fun (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 (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 - ~f:(fun (E { module_ = (module S); instr_witness; expr'; _ }) result -> - match get expr' result with - | None -> failwith "Does not match" - | Some value -> - (* The evaluate the instruction *) - let value = S.Instruction.expression value in - R { value; witness = instr_witness }) - - let call : S.pos -> T.keywords -> expression list -> t = - fun pos keyword args -> - (* The arguments are given like an array of array. Each expression is - 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 - in - - let values = List.rev (Helper.expr_i args expr' i).values in - - let value = S.Instruction.call pos keyword values in - R { witness = instr_witness; value }) - - let act : S.pos -> label:expression -> t list -> t = - fun pos ~label instructions -> - Array.init len ~f:(fun i -> - let (E { module_ = (module S); instr_witness; expr'; _ }) = - Array.get A.t i - in - let values = - List.rev (Helper.expr_i instructions instr_witness i).values - in - - match get expr' (Array.get label i) with - | None -> failwith "Does not match" - | Some label_i -> - let value = S.Instruction.act pos ~label:label_i values in - R { witness = instr_witness; value }) - - (* I think it’s one of the longest module I’ve ever written in OCaml… *) - - let assign : - S.pos -> - (S.pos, expression) S.variable -> - T.assignation_operator -> - expression -> - t = - 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 - in - - let index_i = - Option.map - (fun expression -> - Option.get (get expr' (Array.get expression i))) - index - in - let variable = S.{ pos = var_pos; name; index = index_i } in - - match get expr' (Array.get expression i) with - | None -> failwith "Does not match" - | Some value -> - let value = A.Instruction.assign pos variable op value in - - R { value; witness = instr_witness }) - - let rebuild_clause : - type a b. - int -> - a Id.t -> - b Id.t -> - S.pos * result array * result array list -> - (b, a) S.clause = - fun i instr_witness expr' clause -> - let pos_clause, expr_clause, ts = clause in - match get expr' (Array.get expr_clause i) with - | None -> failwith "Does not match" - | Some value -> - let ts = Helper.expr_i ts instr_witness i in - let ts = List.rev ts.values in - let clause = (pos_clause, value, ts) in - clause - - let if_ : - S.pos -> - (expression, t) S.clause -> - elifs:(expression, t) S.clause list -> - else_:(S.pos * t list) option -> - t = - fun pos clause ~elifs ~else_ -> - (* First, apply the report for all the instructions *) - let else_ = - match else_ with - | None -> None - | Some (pos, instructions) -> Some (pos, instructions) - in - Array.init len ~f:(fun i -> - let (E { module_ = (module A); instr_witness; expr'; _ }) = - Array.get A.t i - in - - let clause = rebuild_clause i instr_witness expr' clause - and elifs = List.map elifs ~f:(rebuild_clause i instr_witness expr') - and else_ = - match else_ with - | None -> None - | Some (pos, instructions) -> - let elses = Helper.expr_i instructions instr_witness i in - Some (pos, List.rev elses.values) - in - - let value = A.Instruction.if_ pos clause ~elifs ~else_ in - R { value; witness = instr_witness }) - - (** This code is almost a copy/paste from Expression.v but I did not found - a way to factorize it. *) - let v : t -> t' = - fun t -> - let result = - Array.map2 A.t t - ~f:(fun - (E { module_ = (module S); instr_witness; instr'; _ }) result -> - match get instr_witness result with - | None -> failwith "Does not match" - | Some value -> - let value = S.Instruction.v value in - R { witness = instr'; value }) - in - result - end - - module Location : - S.Location - with type t = result array - and type instruction = Instruction.t' - and type context := context = struct - type instruction = Instruction.t' - type t = result array - - let location : context -> S.pos -> instruction list -> t = - fun local_context pos args -> - ignore pos; - - let result = - Array.init len ~f:(fun i -> - let (E - { module_ = (module A); instr'; location_witness; context; _ }) - = - Array.get A.t i - in - - let local_context = - Option.get (get context (Array.get local_context i)) - in - - let instructions = List.rev (Helper.expr_i args instr' i).values in - let value = A.Location.location local_context pos instructions in - R { value; witness = location_witness }) - in - result - - let v : t -> Report.t list = - fun args -> - let report = ref [] in - let () = - Array.iteri args ~f:(fun i result -> - let (E { module_ = (module A); location_witness; _ }) = - Array.get A.t i - in - match get location_witness result with - | None -> failwith "Does not match" - | Some value -> - let re = A.Location.v value in - report := List.rev_append re !report) - in - !report - end -end diff --git a/lib/syntax/check.mli b/lib/syntax/check.mli deleted file mode 100644 index 7db719d..0000000 --- a/lib/syntax/check.mli +++ /dev/null @@ -1,53 +0,0 @@ -(** This module is a meta-checker. It will take many checkers and aggregate - their result together before providing an unified result. - - The modules required to be declared before being used, using the [build] - method, and provided as an array : - - {[ - let _, e1 = build (module …) - let _, e2 = build (module …) - - module Check = Make (struct - let t = [| e1; e2 |] - end) - ]} -*) - -module Id : sig - type 'a t - (** The type created on-the-fly. *) -end - -type t -(** Type of check to apply *) - -val 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 Id.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 S.Analyzer) - -type result - -val get : 'a Id.t -> result -> 'a option -(** The method [get] can be used to get the internal value for one of the - checker used. - *) - -module Make (A : sig - val t : t array -end) : sig - include S.Analyzer with type Location.t = result array -end -[@@warning "-67"] diff --git a/lib/syntax/compose.ml b/lib/syntax/compose.ml deleted file mode 100644 index 8c92ed0..0000000 --- a/lib/syntax/compose.ml +++ /dev/null @@ -1,125 +0,0 @@ -(** Build a module with the result from another one module *) - -open StdLabels - -(** 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/syntax/dead_end.ml b/lib/syntax/dead_end.ml deleted file mode 100644 index c0dbc58..0000000 --- a/lib/syntax/dead_end.ml +++ /dev/null @@ -1,171 +0,0 @@ -open StdLabels - -let identifier = "dead_end" -let description = "Check for dead end in the code" -let is_global = false -let active = ref false - -type context = unit - -let initialize = Fun.id -let finalize () = [] - -module Expression = struct - type t = unit - - include Default.Expression (struct - type nonrec t = t - - let default = () - end) - - let v : t -> t' = fun () -> () -end - -module Instruction = struct - type cause = Missing_else | Unchecked_path - - type state = { - block_pos : S.pos; - has_gt : bool; - is_gt : bool; - pos : (cause * S.pos) option; - } - - type t = state - type t' = state - - (** For each instruction, return thoses two informations : - - - the intruction contains at [gt] - - the last instruction is a [gt] - - *) - let v : t -> t' = fun t -> t - - let default = - { - block_pos = (Lexing.dummy_pos, Lexing.dummy_pos); - has_gt = false; - is_gt = false; - pos = None; - } - - (** Call for an instruction like [GT] or [*CLR] *) - let call : S.pos -> T.keywords -> Expression.t' list -> t = - fun pos f _ -> - ignore pos; - match f with - | T.Goto | T.XGoto -> - { block_pos = pos; has_gt = true; is_gt = true; pos = None } - | T.Gosub -> { block_pos = pos; has_gt = false; is_gt = true; pos = None } - | _ -> default - - (** Label for a loop *) - let location : S.pos -> string -> t = fun _ _ -> default - - (** Comment *) - let comment : S.pos -> t = fun _ -> default - - (** 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 *) - let check_block : S.pos -> t list -> t = - fun pos instructions -> - let last_element = - List.fold_left instructions ~init:default ~f:(fun t instruction -> - let result = instruction in - let has_gt = result.has_gt || t.has_gt in - let is_gt = result.is_gt || t.is_gt in - { result with block_pos = pos; is_gt; has_gt }) - in - last_element - - let if_ : - S.pos -> - (Expression.t', t) S.clause -> - elifs:(Expression.t', t) S.clause list -> - else_:(S.pos * t list) option -> - t = - fun pos clause ~elifs ~else_ -> - (* For each block, evaluate the instructions *) - let res, has_gt, is_gt = - List.fold_left ~init:([], false, false) (clause :: elifs) - ~f:(fun (acc, has_gt, is_gt) clause -> - let pos, _, instructions = clause in - let clause_t = check_block pos instructions in - let has_gt = has_gt || clause_t.has_gt - and is_gt = is_gt || clause_t.is_gt in - - ((clause_t, pos) :: acc, has_gt, is_gt)) - in - - let else_pos, else_block = - match else_ with - | Some (pos, instructions) -> - let block = check_block pos instructions in - (pos, block) - | None -> (pos, default) - in - let has_gt = has_gt || else_block.has_gt - and is_gt = is_gt || else_block.is_gt in - - let blocks = (else_block, else_pos) :: res in - - (* Check if one of the clauses already holds a dead end*) - match List.find_opt res ~f:(fun (res, _) -> res.pos != None) with - | Some (v, _) -> v - | None -> ( - match (is_gt, has_gt) with - | _, true -> ( - (* There is gt intruction in one of the branch, we need to checks - the others *) - match List.find_opt blocks ~f:(fun (f, _) -> not f.is_gt) with - | None -> - (* Every branch in the if is covered. It’s ok. *) - { default with block_pos = pos; is_gt; has_gt } - | Some (_, pos) -> - (* TODO check if [pos] is the whole block *) - let cause = - match else_ with None -> Missing_else | _ -> Unchecked_path - in - { default with block_pos = pos; pos = Some (cause, pos) }) - | _, _ -> { default with block_pos = pos; has_gt; is_gt }) - - let act : S.pos -> label:Expression.t' -> t list -> t = - fun pos ~label expressions -> - ignore label; - check_block pos expressions - - let assign : - S.pos -> - (S.pos, Expression.t') S.variable -> - T.assignation_operator -> - Expression.t' -> - t = - fun _ _ _ _ -> default -end - -module Location = struct - type t = Report.t list - - let v = Fun.id - - let location : unit -> S.pos -> Instruction.t' list -> t = - fun () _pos instructions -> - List.fold_left instructions ~init:[] ~f:(fun report t -> - match (t.Instruction.is_gt, t.Instruction.pos) with - | false, Some (cause, value) -> - ignore cause; - if t.Instruction.block_pos != value then - match cause with - | Missing_else -> - Report.debug value "Possible dead end (no else fallback)" - :: report - | Unchecked_path -> - Report.warn value "Possible dead end (unmatched path)" - :: report - else report - | _ -> report) -end diff --git a/lib/syntax/dead_end.mli b/lib/syntax/dead_end.mli deleted file mode 100644 index 451fe58..0000000 --- a/lib/syntax/dead_end.mli +++ /dev/null @@ -1,6 +0,0 @@ -(** Checker looking for the dead ends in the source. - - A dead end is a state where the user does not have any action. - *) - -include S.Analyzer diff --git a/lib/syntax/default.ml b/lib/syntax/default.ml deleted file mode 100644 index d345401..0000000 --- a/lib/syntax/default.ml +++ /dev/null @@ -1,41 +0,0 @@ -(** 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. *) - -module type 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 - index. - - 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 - - (* - 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 - - (** 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 - - (** Unary operator like [-123] or [+'Text']*) - let uoperator : S.pos -> T.uoperator -> T'.t -> T'.t = fun _ _ _ -> 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 -end diff --git a/lib/syntax/dup_test.ml b/lib/syntax/dup_test.ml deleted file mode 100644 index 20faa56..0000000 --- a/lib/syntax/dup_test.ml +++ /dev/null @@ -1,188 +0,0 @@ -(** 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. - *) - -open StdLabels - -let identifier = "duplicate_test" -let description = "Check for duplicate tests" -let is_global = false -let active = ref true - -type context = unit - -let initialize = Fun.id -let finalize () = [] - -module Expression = Tree.Expression - -(** Build a Hashtbl over the expression, ignoring the location in the - expression *) -module Table = Hashtbl.Make (struct - type t = Expression.t' - - let equal : t -> t -> bool = Tree.Expression.eq (fun _ _ -> true) - let hash : t -> int = Tree.Expression.hash (fun _ -> 0) -end) - -module Instruction = struct - type state = { - 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. *) - - 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 - - (** Comment *) - let comment : S.pos -> t = fun _ -> default - - (** Raw expression *) - let expression : Expression.t' -> t = fun _ -> default - - let check_duplicates : - (Expression.t' * S.pos) list -> (Expression.t' * S.pos list) list = - fun predicates -> - let table = Table.create 5 in - let () = List.to_seq predicates |> Table.add_seq table in - - Table.to_seq_keys table - |> Seq.group (Tree.Expression.eq (fun _ _ -> true)) - |> Seq.filter_map (fun keys -> - (* Only take the first element for each group, we don’t need to - repeat the key *) - match Seq.uncons keys with - | None -> None - | Some (hd, _) -> ( - match Table.find_all table hd with - | [] | _ :: [] -> None - | 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 *) - let predicate_of_clause : ?pos:S.pos -> t -> (Expression.t', t) S.clause -> t - = - fun ?pos t (pos2, predicate, blocks) -> - let pos = Option.value ~default:pos2 pos in - - (* Remove the clauses using the function rnd because they repeating the - same clause can generate a different result *) - let should_discard = - Tree.Expression.exists predicate ~f:(function - | Tree.Ast.Function (_, T.Rand, _) | Tree.Ast.Function (_, T.Rnd, _) -> - true - | _ -> false) - in - - { - predicates = - (match should_discard with - | false -> (predicate, pos) :: t.predicates - | true -> t.predicates); - duplicates = - List.fold_left blocks ~init:t.duplicates ~f:(fun acc t -> - List.rev_append t.duplicates acc); - } - - let if_ : - S.pos -> - (Expression.t', t) S.clause -> - elifs:(Expression.t', t) S.clause list -> - else_:(S.pos * t list) option -> - t = - fun pos clause ~elifs ~else_ -> - ignore else_; - (* Collect all the if clauses from this block, wait for the parent block to - check each case for duplicates. *) - let init = predicate_of_clause ~pos default clause in - let state = List.fold_left elifs ~init ~f:predicate_of_clause in - { - 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 - type t = (Expression.t' * S.pos list) list - - type context = unit - (** No context *) - - (** Check if the given expression is involving the variable ARGS or $ARGS *) - let is_args : Expression.t' -> bool = function - | Tree.Ast.Ident { name; _ } -> - String.equal name "ARGS" || String.equal name "$ARGS" - | _ -> false - - let location : context -> S.pos -> Instruction.t' list -> t = - fun () _ block -> - (* Filter the tests from the top level and only keep them testing ARGS *) - let duplicates = - List.map block ~f:(fun t -> - List.filter_map t.Instruction.predicates ~f:(fun v -> - match (Tree.Expression.exists ~f:is_args) (fst v) with - | true -> Some v - | false -> None)) - |> List.concat |> Instruction.check_duplicates - in - List.fold_left ~init:duplicates block ~f:(fun state ex -> - List.rev_append ex.Instruction.duplicates state) - - (** Create the report message *) - let v' : Expression.t' * S.pos list -> Report.t option = - fun (expr, pos) -> - ignore expr; - match (List.sort ~cmp:Report.compare_pos) pos with - | [] -> None - | _ :: [] -> None - | hd :: tl -> - let message = - Format.asprintf "This case is duplicated line(s) %a" - (Format.pp_print_list - ~pp_sep:(fun f () -> Format.pp_print_char f ',') - Report.pp_line) - tl - in - - (* Report all the messages as error. They do not break the game, but - there is no question if it should *) - Some (Report.error hd message) - - let v : t -> Report.t list = - fun t -> List.filter_map t ~f:v' |> List.sort_uniq ~cmp:Report.compare -end diff --git a/lib/syntax/dup_test.mli b/lib/syntax/dup_test.mli deleted file mode 100644 index 38e3a1b..0000000 --- a/lib/syntax/dup_test.mli +++ /dev/null @@ -1 +0,0 @@ -include S.Analyzer diff --git a/lib/syntax/get_type.ml b/lib/syntax/get_type.ml deleted file mode 100644 index b22f53c..0000000 --- a/lib/syntax/get_type.ml +++ /dev/null @@ -1,121 +0,0 @@ -open StdLabels - -type type_of = - | Integer (** A numeric value *) - | Bool (** A boolean, not a real type *) - | String (** String value *) - | NumericString - [@printer fun fmt _ -> Format.pp_print_string fmt "Integer as String"] - (** 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 - 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' -> ( - try List.hd params with Failure _ -> Raw Bool) - | 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 diff --git a/lib/syntax/locations.ml b/lib/syntax/locations.ml deleted file mode 100644 index 17f33bd..0000000 --- a/lib/syntax/locations.ml +++ /dev/null @@ -1,159 +0,0 @@ -open StdLabels - -module IgnoreCaseString = struct - type t = string - - let compare t1 t2 = - String.compare (String.lowercase_ascii t1) (String.lowercase_ascii t2) - - let equal t1 t2 = - String.equal (String.lowercase_ascii t1) (String.lowercase_ascii t2) -end - -module LocationSet = Set.Make (IgnoreCaseString) -module LocationCalls = Map.Make (IgnoreCaseString) - -let identifier = "locations" -let description = "Ensure every call points to an existing location" -let is_global = true -let active = ref true - -type t = { - locations : LocationSet.t; - calls : (string * S.pos) list LocationCalls.t; -} - -type context = t ref - -let initialize () = - ref { locations = LocationSet.empty; calls = LocationCalls.empty } - -let finalize : context -> (string * Report.t) list = - fun context -> - LocationCalls.fold - (fun location positions acc -> - let message = Printf.sprintf "The location %s does not exists" location in - - List.fold_left ~init:acc (List.rev positions) - ~f:(fun acc (loc, position) -> - let report = Report.error position message in - (loc, report) :: acc)) - !context.calls [] - -(** Register a new call to a defined location. *) -let registerCall : S.pos -> string -> t -> t = - fun pos location t -> - let file_name = (fst pos).Lexing.pos_fname in - match - IgnoreCaseString.equal location file_name - || LocationSet.mem location t.locations - with - | true -> t - | false -> - (* The location is not yet defined, register the call for later *) - let calls = - LocationCalls.update location - (function - | None -> Some [ (file_name, pos) ] - | Some poss -> - Some - (let new_pos = (file_name, pos) in - new_pos :: poss)) - t.calls - in - { t with calls } - -(** Add a new location in the list of all the collected elements *) -let registerLocation : string -> t -> t = - fun location t -> - let calls = LocationCalls.remove location t.calls - and locations = LocationSet.add location t.locations in - { calls; locations } - -(** The module Expression is pretty simple, we are only interrested by the - strings ( because only the first argument of [gt …] is read ). - - If the string is too much complex, we just ignore it. *) -module Expression = struct - type t = string option - - include Default.Expression (struct - type nonrec t = t - - let default = None - end) - - 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 -end - -module Instruction = struct - type nonrec t = t -> t - type t' = t - - let v : t -> t' = Fun.id - - (** Keep a track of every gt or gs instruction *) - let call : S.pos -> T.keywords -> Expression.t' list -> t = - fun pos fn args t -> - match (fn, args) with - | 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 - type t = unit - - let v : t -> Report.t list = fun () -> [] - - let location : context -> S.pos -> Instruction.t list -> t = - fun context pos instructions -> - (* Register the location *) - let file_name = (fst pos).Lexing.pos_fname in - let c = registerLocation file_name !context in - (* Then update the list of all the calls to the differents locations *) - context := - List.fold_left instructions ~init:c ~f:(fun t instruction -> - instruction t) -end diff --git a/lib/syntax/nested_strings.ml b/lib/syntax/nested_strings.ml deleted file mode 100644 index dee7af0..0000000 --- a/lib/syntax/nested_strings.ml +++ /dev/null @@ -1,156 +0,0 @@ -open StdLabels - -let identifier = "escaped_string" -let description = "Check for unnecessary use of expression encoded in string" -let is_global = false -let active = ref true - -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 - type t' = Report.t list - - let v : Get_type.t Lazy.t * t -> t' = snd - - (** Identify the expressions reprented as string. That’s here that the report - 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 -> - match content with - | [ T.Expression (t', _); T.Text "" ] -> ( - match Get_type.get_type (Lazy.force t') with - | Get_type.Integer -> [] - | _ -> - let msg = Report.debug pos "This expression can be simplified" in - [ msg ]) - | _ -> [] - - 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 integer : S.pos -> string -> Get_type.t Lazy.t -> t = - fun pos t _type_of -> - ignore pos; - ignore t; - [] - - 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 -> - ignore pos; - ignore f; - let exprs = - List.fold_left ~init:[] expressions ~f:(fun acc el -> - List.rev_append (snd el) acc) - in - 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 -> - ignore op; - ignore pos; - snd r - - 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 -> - ignore pos; - ignore op; - r1 @ r2 -end) - -module Instruction : - S.Instruction with type t' = Report.t list and type expression = Expression.t' = -struct - type t = Report.t list - (** Internal type used in the evaluation *) - - type t' = t - - let v : t -> t' = Fun.id - - type expression = Expression.t' - - let call : S.pos -> T.keywords -> expression list -> t = - fun pos k exprs -> - ignore pos; - ignore k; - List.concat exprs - - let location : S.pos -> string -> t = fun _ _ -> [] - let comment : S.pos -> t = fun _ -> [] - let expression : expression -> t = Fun.id - - let act : S.pos -> label:expression -> t list -> t = - fun pos ~label instructions -> - ignore pos; - List.concat (label :: instructions) - - let fold_clause : (expression, t) S.clause -> t = - fun (_pos1, expression, ts) -> List.concat (expression :: ts) - - let if_ : - S.pos -> - (expression, t) S.clause -> - elifs:(expression, t) S.clause list -> - else_:(S.pos * t list) option -> - t = - fun pos clause ~elifs ~else_ -> - ignore pos; - - let init = - match else_ with - | None -> fold_clause clause - | Some (_, ts) -> List.rev_append (fold_clause clause) (List.concat ts) - in - - List.fold_left elifs ~init ~f:(fun t clause -> - List.rev_append (fold_clause clause) t) - - let assign : - S.pos -> - (S.pos, expression) S.variable -> - T.assignation_operator -> - expression -> - t = - fun pos variable op expression -> - ignore pos; - ignore op; - match variable.index with - | None -> expression - | Some v -> List.rev_append v expression -end - -module Location = struct - type t = Report.t list - type instruction = Instruction.t' - - let v = Fun.id - - let location : unit -> S.pos -> instruction list -> t = - fun () pos intructions -> - ignore pos; - List.concat intructions -end diff --git a/lib/syntax/nested_strings.mli b/lib/syntax/nested_strings.mli deleted file mode 100644 index 38e3a1b..0000000 --- a/lib/syntax/nested_strings.mli +++ /dev/null @@ -1 +0,0 @@ -include S.Analyzer diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml deleted file mode 100644 index 97b7f91..0000000 --- a/lib/syntax/type_of.ml +++ /dev/null @@ -1,488 +0,0 @@ -open StdLabels - -let identifier = "type_check" -let description = "Ensure all the expression are correctly typed" -let is_global = false -let active = ref true - -type context = unit - -let initialize = Fun.id -let finalize () = [] - -module Helper = struct - type argument_repr = { pos : S.pos; t : Get_type.t } - - module DynType = struct - type nonrec t = Get_type.t -> Get_type.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.*) - - (** Build a new dynamic type *) - let t : unit -> t = - fun () -> - let stored = ref None in - fun t -> - match !stored with - | None -> - stored := Some t; - t - | Some t -> t - end - - (** 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. *) - type argument = - | Fixed of Get_type.type_of - | Dynamic of DynType.t - | Variable of argument - - let compare : - ?level:Report.level -> - strict:bool -> - Get_type.type_of -> - argument_repr -> - Report.t list -> - Report.t list = - fun ?(level = Report.Warn) ~strict expected actual report -> - let equal = - match (expected, actual.t) with - (* Strict equality for this ones, always true *) - | String, Variable String - | String, Raw String - | String, Variable NumericString - | String, Raw NumericString - | Integer, Variable Integer - | Integer, Raw Integer - | NumericString, Variable NumericString - | NumericString, Raw NumericString - | Bool, Raw Bool - | Bool, Variable Bool - (* Also include the conversion between bool and integer *) - | Integer, Raw Bool - | Integer, Variable Bool - (* The type NumericString can be used as a generic type in input *) - | _, Variable NumericString - | NumericString, Raw String - | NumericString, Variable String - | NumericString, Raw Integer - | NumericString, Variable Integer -> - true - | Bool, Variable Integer - | Bool, Raw Integer - | String, Variable Integer - | String, Raw Bool - | String, Variable Bool - | Integer, Variable String - | Integer, Raw NumericString -> - not strict - (* Explicit rejected cases *) - | String, Raw Integer | Integer, Raw String -> false - | _, _ -> false - in - if equal then report - else - let result_type = match actual.t with Variable v -> v | Raw r -> r in - let message = - Format.asprintf "The type %a is expected but got %a" Get_type.pp_type_of - expected Get_type.pp_type_of result_type - in - Report.message level actual.pos message :: report - - let rec compare_parameter : - strict:bool -> - ?level:Report.level -> - argument -> - argument_repr -> - Report.t list -> - Report.t list = - fun ~strict ?(level = Report.Warn) expected param report -> - match expected with - | Fixed t -> compare ~strict ~level t param report - | Dynamic d -> - let type_ = match d param.t with Raw r -> r | Variable v -> v in - compare ~strict ~level type_ param report - | Variable c -> compare_parameter ~level ~strict c param report - - (** Compare the arguments one by one *) - let compare_args : - ?strict:bool -> - ?level:Report.level -> - S.pos -> - argument list -> - argument_repr list -> - Report.t list -> - Report.t list = - fun ?(strict = false) ?(level = Report.Warn) pos expected actuals report -> - let tl, report = - List.fold_left actuals ~init:(expected, report) - ~f:(fun (expected, report) param -> - match expected with - | (Variable _ as hd) :: _ -> - let check = compare_parameter ~strict ~level hd param report in - (expected, check) - | hd :: tl -> - let check = compare_parameter ~strict ~level hd param report in - (tl, check) - | [] -> - let msg = Report.error param.pos "Unexpected argument" in - ([], msg :: report)) - in - match tl with - | [] | Variable _ :: _ -> report - | _ -> - let msg = Report.error pos "Not enougth arguments given" in - msg :: report -end - -module TypeBuilder = Compose.Expression (Get_type) - -type t' = { result : Get_type.t Lazy.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 } - -module TypedExpression = struct - type nonrec t' = t' * Report.t list - type state = { pos : S.pos } - 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) - - (** 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 -> - (* Extract the error from the index *) - let report = - match var.index with - | None -> [] - | Some (_, expr) -> - let _, r = expr in - r - in - ({ pos = var.pos }, report) - - let integer : S.pos -> string -> Get_type.t Lazy.t -> t = - fun pos value _type_of -> - let int_value = int_of_string_opt value in - - let report = - match int_value with - | Some 0 -> [] - | Some _ -> [] - | None -> Report.error pos "Invalid integer value" :: [] - in - - ({ pos }, 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; - let init = [] in - let report = - List.fold_left values ~init ~f:(fun report -> function - | T.Text _ -> report - | T.Expression (_, t) -> - let report = List.rev_append (snd t) report in - report) - in - ({ pos }, 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 -> - (* 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; - let t, r = param in - let arg = arg_of_repr type_of t.pos in - (arg :: types, r @ report)) - in - let types = List.rev types and default = { pos } in - - match function_ with - | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Getobj | Instr - | Isplay -> - (default, report) - | Desc' | Dyneval' | Getobj' -> (default, report) - | Func | Func' -> (default, report) - | Iif | Iif' -> - let d = Helper.DynType.t () in - 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) - | Input | Input' -> - (* Input should check the result if the variable is a num and raise a - message in this case.*) - let expected = Helper.[ Fixed String ] in - let report = Helper.compare_args pos expected types report in - (default, report) - | Isnum -> - let expected = Helper.[ Fixed String ] in - let report = Helper.compare_args pos expected types report in - (default, report) - | Lcase | Lcase' | Ucase | Ucase' -> - let expected = Helper.[ Fixed String ] in - let report = Helper.compare_args pos expected types report in - (default, report) - | Len -> - let expected = Helper.[ Fixed NumericString ] in - let report = Helper.compare_args pos expected types report in - (default, report) - | Loc -> - let expected = Helper.[ Fixed String ] in - let report = Helper.compare_args pos expected types report in - (default, report) - | Max | Max' | Min | Min' -> - let d = Helper.DynType.t () in - (* 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) - | Mid | Mid' -> - let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in - let report = Helper.compare_args pos expected types report in - (default, report) - | Msecscount -> (default, report) - | Rand -> - let expected = Helper.[ Variable (Fixed Integer) ] in - let report = Helper.compare_args pos expected types report in - (default, report) - | Replace -> (default, report) - | Replace' -> (default, report) - | Rgb -> (default, report) - | Rnd -> - (* No arg *) - let report = Helper.compare_args pos [] types report in - (default, report) - | Selact -> (default, report) - | Str | Str' -> - let expected = Helper.[ Variable (Fixed Integer) ] in - let report = Helper.compare_args pos expected types report in - (default, report) - | Strcomp -> (default, report) - | Strfind -> (default, report) - | Strfind' -> (default, report) - | Strpos -> (default, report) - | Trim -> (default, report) - | Trim' -> (default, report) - | Val -> - let expected = Helper.[ Fixed NumericString ] in - let report = Helper.compare_args pos expected types report in - (default, report) - - (** 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 - match operator with - | Add -> (t, report) - | Neg | No -> - let types = [ arg_of_repr type_of t.pos ] in - let expected = Helper.[ Fixed Integer ] in - let report = Helper.compare_args pos expected types report in - ({ pos }, 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; - let t1, report1 = t1 in - let t2, report2 = t2 in - - let report = report1 @ report2 in - - let types = [ arg_of_repr type_1 t1.pos; arg_of_repr type_2 t2.pos ] in - - match operator with - | T.Plus -> - (* We cannot really much here, because the (+) function can be used to - concatenate string or add numbers. - - When concatenating, it’s allowed to add an integer and a number. - *) - ({ pos }, 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 *) - let d = Helper.(Dynamic (DynType.t ())) in - let expected = [ d; d ] in - (* Compare and report as error if the types are incompatible. If no - error is reported, try in strict mode, and report as a warning. *) - let report = - match - Helper.compare_args ~level:Error pos expected (List.rev types) - report - with - | [] -> - Helper.compare_args ~strict:true pos expected (List.rev types) - report - | report -> report - in - ({ pos }, 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) - | 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) -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 - - type expression = Expression.t' - - (** Call for an instruction like [GT] or [*CLR] *) - let call : S.pos -> T.keywords -> expression list -> t = - fun _pos _ expressions -> - List.fold_left expressions ~init:[] ~f:(fun acc a -> - let _, report = a in - (List.rev_append report) acc) - - let location : S.pos -> string -> t = fun _pos _ -> [] - - (** Comment *) - let comment : S.pos -> t = fun _pos -> [] - - (** Raw expression *) - let expression : expression -> t = fun expression -> snd expression - - (** Helper function used in the [if_] function. *) - let fold_clause : t -> (expression, t) S.clause -> t = - fun report (_pos, expr, instructions) -> - let result, r = expr in - - let r2 = - Helper.compare ~strict:false Get_type.Bool - (arg_of_repr result.result result.pos) - [] - in - - List.fold_left instructions - ~init:(r @ r2 @ report) - ~f:(fun acc a -> - let report = a in - (List.rev_append report) acc) - - let if_ : - S.pos -> - (expression, t) S.clause -> - elifs:(expression, t) S.clause list -> - else_:(S.pos * t list) option -> - t = - fun _pos clause ~elifs ~else_ -> - (* Traverse the whole block recursively *) - let report = fold_clause [] clause in - let report = List.fold_left elifs ~f:fold_clause ~init:report in - - match else_ with - | None -> report - | Some (_, instructions) -> - List.fold_left instructions ~init:report ~f:(fun acc a -> - let report = a in - (List.rev_append report) acc) - - let act : S.pos -> label:expression -> t list -> t = - fun _pos ~label instructions -> - let result, report = label in - let report = - Helper.compare ~strict:false Get_type.String - (arg_of_repr result.result result.pos) - report - in - - List.fold_left instructions ~init:report ~f:(fun acc a -> - let report = a in - (List.rev_append report) acc) - - let assign : - S.pos -> - (S.pos, expression) S.variable -> - T.assignation_operator -> - expression -> - t = - fun pos variable op expression -> - let right_expression, report = expression in - - let report' = Option.map snd variable.index |> Option.value ~default:[] in - - let report = List.rev_append report' report in - - match (op, Get_type.get_type (Lazy.force 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 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 op1 = arg_of_repr var_type variable.pos in - let op2 = arg_of_repr right_expression.result right_expression.pos in - - let d = Helper.DynType.t () in - (* Every part of the assignation should be the same type *) - let expected = Helper.[ Dynamic d; Dynamic d ] in - - match - Helper.compare_args ~strict:false ~level:Report.Error pos expected - [ op1; op2 ] [] - with - | [] -> - Helper.compare_args ~strict:true ~level:Report.Warn pos expected - [ op1; op2 ] report - | reports -> reports @ report) -end - -module Location = struct - type t = Report.t list - type instruction = Instruction.t' - - let v = Fun.id - - let location : unit -> S.pos -> instruction list -> t = - fun () _pos instructions -> - let report = - List.fold_left instructions ~init:[] ~f:(fun report instruction -> - let report' = instruction in - report' @ report) - in - report -end diff --git a/lib/syntax/type_of.mli b/lib/syntax/type_of.mli deleted file mode 100644 index 551f9ac..0000000 --- a/lib/syntax/type_of.mli +++ /dev/null @@ -1,7 +0,0 @@ -include S.Analyzer -(** The module [type_of] populate the report with differents inconsistency - 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. *) diff --git a/lib/syntax/write_only.ml b/lib/syntax/write_only.ml deleted file mode 100644 index ec2e368..0000000 --- a/lib/syntax/write_only.ml +++ /dev/null @@ -1,217 +0,0 @@ -(** Check all the write_only variables *) - -open StdLabels - -(** Identifier for the module *) -let identifier = "write_only" - -(** Short description*) -let description = "Check variables never read" - -(** Is the test active or not *) -let active = ref false - -let is_global = true - -module Key = struct - type t = string - - let equal = String.equal - let hash = Hashtbl.hash - let compare = String.compare -end - -module StringMap = Hashtbl.Make (Key) -module Set = Set.Make (Key) - -type data = { write : bool; read : bool; position : S.pos list } -type context = (string * data) StringMap.t - -let initialize () = StringMap.create 16 - -let keywords = - [ - "BACKIMAGE"; - "$BACKIMAGE"; - "BCOLOR"; - "DEBUG"; - "DISABLESCROLL"; - "DISABLESUBEX"; - "FCOLOR"; - "$FNAME"; - "FSIZE"; - "GC"; - "LCOLOR"; - "NOSAVE"; - ] - |> Set.of_list - -let set_readed : - ?update_only:bool -> S.pos -> string -> string -> context -> unit = - fun ?(update_only = false) pos identifier filename map -> - if not (Set.mem identifier keywords) then - match (update_only, StringMap.find_opt map identifier) with - | false, None -> - StringMap.add map identifier - (filename, { write = false; read = true; position = [] }) - | _, Some (filename, v) -> - StringMap.replace map identifier - (filename, { v with read = true; position = pos :: v.position }) - | true, None -> () - -let set_write : S.pos -> string -> string -> context -> unit = - fun pos identifier filename map -> - if not (Set.mem identifier keywords) then - match StringMap.find_opt map identifier with - | None -> - StringMap.add map identifier - (filename, { write = true; read = false; position = pos :: [] }) - | Some (filename, v) -> - StringMap.replace map identifier - (filename, { v with write = true; position = pos :: v.position }) - -module Expression = struct - type t = string -> context -> unit - - let v : t -> t = Fun.id - - include Default.Expression (struct - type nonrec t = t - - let default _ map = ignore map - end) - - let ident : (S.pos, t) S.variable -> t = - fun variable filename map -> - (* 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 -> - List.iter l ~f:(function - | T.Text t -> - set_readed pos ~update_only:true (String.uppercase_ascii t) filename - map - | T.Expression exprs -> - (* 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 uoperator : S.pos -> T.uoperator -> t -> t = fun _ _ t map -> t map - - let boperator : S.pos -> T.boperator -> t -> t -> t = - fun _ _ t1 t2 filename map -> - t1 filename map; - t2 filename map -end - -module Instruction = struct - type t = Expression.t - (** Internal type used in the evaluation *) - - type t' = t - - let v : t -> t' = Fun.id - - type expression = Expression.t - - let location : S.pos -> string -> t = fun _pos _ _ _ -> () - - let call : S.pos -> T.keywords -> expression list -> t = - fun _ op exprs filename map -> - match op with - | T.KillVar -> - (* Killing a variable does not count as reading it *) - () - | _ -> List.iter ~f:(fun v -> v filename map) exprs - - let comment : S.pos -> t = fun _ _ _ -> () - let expression : expression -> t = fun expression map -> expression map - - let fold_clause : (expression, t) S.clause -> t = - fun clause filename map -> - let _, expr, exprs = clause in - let () = expr filename map in - let () = List.iter ~f:(fun v -> v filename map) exprs in - () - - let if_ : - S.pos -> - (expression, t) S.clause -> - elifs:(expression, t) S.clause list -> - else_:(S.pos * t list) option -> - t = - fun pos clauses ~elifs ~else_ filename map -> - ignore pos; - let () = fold_clause clauses filename map in - let () = List.iter ~f:(fun v -> fold_clause v filename map) elifs in - Option.iter - (fun (_, exprs) -> List.iter exprs ~f:(fun v -> v filename map)) - else_; - () - - let act : S.pos -> label:expression -> t list -> t = - fun pos ~label exprs filename map -> - ignore pos; - ignore label; - List.iter ~f:(fun v -> v filename map) exprs - - let assign : - S.pos -> - (S.pos, expression) S.variable -> - T.assignation_operator -> - expression -> - t = - fun pos variable op expr filename map -> - ignore op; - ignore expr; - Option.iter (fun v -> v filename map) variable.index; - expr filename map; - set_write pos variable.name filename map -end - -module Location = struct - type t = unit - type instruction = string -> context -> unit - - let v : t -> Report.t list = fun _ -> [] - - let location : context -> S.pos -> instruction list -> t = - fun context pos instructions -> - let file_name = (snd pos).Lexing.pos_fname in - ignore pos; - ignore context; - let () = List.iter ~f:(fun v -> v file_name context) instructions in - () -end - -(** Extract the results from the whole parsing *) -let finalize : context -> (string * Report.t) list = - fun map -> - let () = - StringMap.filter_map_inplace - (fun _ (loc, value) -> - match value.read && value.write with - | true -> None - | false -> Some (loc, value)) - map - in - - let report = - StringMap.fold - (fun ident (loc, value) report -> - match value.read with - | false -> - List.fold_left value.position ~init:report ~f:(fun report pos -> - let msg = - Report.debug pos - (String.concat ~sep:" " - [ "The variable"; ident; "is never read" ]) - in - (loc, msg) :: report) - | true -> report) - map [] - in - report -- cgit v1.2.3