diff options
-rw-r--r-- | bin/args.ml | 2 | ||||
-rw-r--r-- | bin/args.mli | 2 | ||||
-rw-r--r-- | bin/qsp_parser.ml | 19 | ||||
-rw-r--r-- | lib/checks/check.ml | 163 | ||||
-rw-r--r-- | lib/checks/check.mli | 64 | ||||
-rw-r--r-- | lib/syntax/S.ml | 27 | ||||
-rw-r--r-- | lib/syntax/catalog.ml | 48 | ||||
-rw-r--r-- | lib/syntax/catalog.mli | 30 | ||||
-rw-r--r-- | test/syntax.ml | 18 |
9 files changed, 181 insertions, 192 deletions
diff --git a/bin/args.ml b/bin/args.ml index b124575..1503d18 100644 --- a/bin/args.ml +++ b/bin/args.ml @@ -74,7 +74,7 @@ let speclist printer = common_arguments @ windows_arguments let parse : - modules:Qsp_checks.Check.t list -> + modules:Qsp_syntax.Catalog.ex list -> list_tests:(Format.formatter -> unit) -> string list * t = fun ~modules ~list_tests -> diff --git a/bin/args.mli b/bin/args.mli index 0041b59..a98b258 100644 --- a/bin/args.mli +++ b/bin/args.mli @@ -4,6 +4,6 @@ type t = { reset_line : bool; filters : filters } (** All the arguments given from the command line *) val parse : - modules:Qsp_checks.Check.t list -> + modules:Qsp_syntax.Catalog.ex list -> list_tests:(Format.formatter -> unit) -> string list * t diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml index cdd509c..a8ee457 100644 --- a/bin/qsp_parser.ml +++ b/bin/qsp_parser.ml @@ -19,12 +19,12 @@ type ctx = { error_nb : int; warn_nb : int; debug_nb : int; fatal_error : bool } *) let available_checks = [ - snd @@ Qsp_checks.Check.build (module Qsp_checks.Type_of); - snd @@ Qsp_checks.Check.build (module Qsp_checks.Dead_end); - snd @@ Qsp_checks.Check.build (module Qsp_checks.Nested_strings); - snd @@ Qsp_checks.Check.build (module Qsp_checks.Locations); - snd @@ Qsp_checks.Check.build (module Qsp_checks.Dup_test); - snd @@ Qsp_checks.Check.build (module Qsp_checks.Write_only); + snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Type_of); + snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dead_end); + snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Nested_strings); + snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Locations); + snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dup_test); + snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Write_only); ] let pp_module formatter (module A : Qsp_syntax.S.Analyzer) = @@ -70,8 +70,8 @@ let pp_modules formatter = (** Get all the tests to apply. - The expression is declared lazy in order to be sure to apply the filters - from the command line before. *) + The expression is declared lazy in order to be sure to apply the filters + from the command line before. *) let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t = lazy (let module Check = Qsp_checks.Check.Make (struct @@ -89,8 +89,7 @@ let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t = read properly), or until the first syntax error. The function update the context (list of errors) passed in arguments. *) -let parse_location : - type context. +let parse_location : type context. ctx:ctx ref -> (module Qsp_syntax.S.Analyzer with type context = context) -> context -> diff --git a/lib/checks/check.ml b/lib/checks/check.ml index 76d5c34..6169bb1 100644 --- a/lib/checks/check.ml +++ b/lib/checks/check.ml @@ -1,66 +1,20 @@ -module Id = Type.Id +module S = Qsp_syntax.S +module C = Qsp_syntax.Catalog (** The the Id module, wrap a value in an existencial type with a witness associate with. *) -type result = R : { value : 'a; witness : 'a Id.t } -> result +type result = R : { value : 'a; witness : 'a Type.Id.t } -> result -let get : type a. a Id.t -> result -> a option = +let get : type a. a Type.Id.t -> result -> a option = fun typeid (R { value; witness }) -> - match Id.provably_equal typeid witness with + match Type.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)) +type t = Qsp_syntax.Catalog.ex + +let get_module : t -> (module S.Analyzer) = + fun (E { module_; _ }) -> (module_ :> (module S.Analyzer)) module type App = sig val t : t array @@ -69,9 +23,9 @@ end open StdLabels module Helper = struct - type 'a expr_list = { witness : 'a Id.t; values : 'a list } + type 'a expr_list = { witness : 'a Type.Id.t; values : 'a list } - let expr_i : result array list -> 'a Id.t -> int -> 'a expr_list = + let expr_i : result array list -> 'a Type.Id.t -> int -> 'a expr_list = fun args witness i -> let result = List.fold_left args ~init:{ values = []; witness } @@ -96,7 +50,7 @@ module Make (A : App) = struct (** 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; _ }) -> + Array.map A.t ~f:(fun (C.E { module_ = (module S); context; _ }) -> let value = S.initialize () in R { value; witness = context }) @@ -104,7 +58,7 @@ module Make (A : App) = struct fun context_array -> let _, report = Array.fold_left A.t ~init:(0, []) - ~f:(fun (i, acc) (E { module_ = (module S); context; _ }) -> + ~f:(fun (i, acc) (C.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 @@ -115,14 +69,14 @@ module Make (A : App) = struct (* Global variable for the whole module *) let len = Array.length A.t - module Expression : Qsp_syntax.S.Expression with type t' = result array = - struct + module Expression : 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 = + let literal : 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; _ }) -> + Array.mapi A.t + ~f:(fun i (C.E { module_ = (module S); expr_witness; _ }) -> (* Map every values to the Checker *) let values' = List.map values @@ -133,14 +87,14 @@ module Make (A : App) = struct let value = S.Expression.literal pos values' in R { value; witness = expr_witness }) - let integer : Qsp_syntax.S.pos -> string -> t = + let integer : S.pos -> string -> t = fun pos value -> - Array.map A.t ~f:(fun (E { module_ = (module S); expr_witness; _ }) -> + Array.map A.t ~f:(fun (C.E { module_ = (module S); expr_witness; _ }) -> let value = S.Expression.integer pos value in R { value; witness = expr_witness }) (** Unary operator like [-123] or [+'Text']*) - let uoperator : Qsp_syntax.S.pos -> Qsp_syntax.T.uoperator -> t -> t = + let uoperator : S.pos -> Qsp_syntax.T.uoperator -> t -> t = fun pos op values -> (* Evaluate the nested expression *) let results = values in @@ -156,7 +110,7 @@ module Make (A : App) = struct *) let results = Array.map2 A.t results - ~f:(fun (E { module_ = (module S); expr_witness; _ }) value -> + ~f:(fun (C.E { module_ = (module S); expr_witness; _ }) value -> match get expr_witness value with | None -> failwith "Does not match" | Some value -> @@ -168,7 +122,7 @@ module Make (A : App) = struct (** 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 = + let boperator : S.pos -> Qsp_syntax.T.boperator -> t -> t -> t = fun pos op expr1 expr2 -> Array.init len ~f:(fun i -> let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in @@ -182,7 +136,7 @@ module Make (A : App) = struct | _ -> 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 = + let function_ : S.pos -> Qsp_syntax.T.function_ -> t list -> t = fun pos func args -> Array.init len ~f:(fun i -> let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in @@ -191,8 +145,8 @@ module Make (A : App) = struct 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 } -> + 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 @@ -216,7 +170,8 @@ module Make (A : App) = struct fun t -> let result = Array.map2 A.t t - ~f:(fun (E { module_ = (module S); expr_witness; expr'; _ }) result -> + ~f:(fun + (C.E { module_ = (module S); expr_witness; expr'; _ }) result -> match get expr_witness result with | None -> failwith "Does not match" | Some value -> @@ -227,29 +182,30 @@ module Make (A : App) = struct end module Instruction : - Qsp_syntax.S.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 : Qsp_syntax.S.pos -> string -> t = + let location : S.pos -> string -> t = fun pos label -> - Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) -> + Array.map A.t ~f:(fun (C.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 = + let comment : S.pos -> t = fun pos -> - Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) -> + Array.map A.t ~f:(fun (C.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 -> + ~f:(fun + (C.E { module_ = (module S); instr_witness; expr'; _ }) result -> match get expr' result with | None -> failwith "Does not match" | Some value -> @@ -257,8 +213,7 @@ module Make (A : App) = struct 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 - = + let call : 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. *) @@ -272,7 +227,7 @@ module Make (A : App) = struct 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 = + 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'; _ }) = @@ -291,8 +246,8 @@ module Make (A : App) = struct (* 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 -> + S.pos -> + (S.pos, expression) S.variable -> Qsp_syntax.T.assignation_operator -> expression -> t = @@ -308,9 +263,7 @@ module Make (A : App) = struct Option.get (get expr' (Array.get expression i))) index in - let variable = - Qsp_syntax.S.{ pos = var_pos; name; index = index_i } - 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" @@ -319,13 +272,12 @@ module Make (A : App) = struct R { value; witness = instr_witness }) - let rebuild_clause : - type a b. + 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 = + a Type.Id.t -> + b Type.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 @@ -337,10 +289,10 @@ module Make (A : App) = struct 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 -> + 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 *) @@ -367,14 +319,14 @@ module Make (A : App) = struct 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. *) + (** 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 -> + (C.E { module_ = (module S); instr_witness; instr'; _ }) result -> match get instr_witness result with | None -> failwith "Does not match" | Some value -> @@ -385,22 +337,27 @@ module Make (A : App) = struct end module Location : - Qsp_syntax.S.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 -> Qsp_syntax.S.pos -> instruction list -> t = + 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; _ }) - = + { + module_ = (module A); + instr'; + location_witness; + context; + _; + }) = Array.get A.t i in diff --git a/lib/checks/check.mli b/lib/checks/check.mli index 321b67b..8502753 100644 --- a/lib/checks/check.mli +++ b/lib/checks/check.mli @@ -1,68 +1,28 @@ (** This module is a meta-checker. It will take many checkers and aggregate - their result together before providing an unified result. + 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) - ]} -*) + {[ + let _, e1 = build (module …) + let _, e2 = build (module …) -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. *) + module Check = Make (struct + let t = [| e1; e2 |] + end) + ]} *) -val get_module : t -> (module Qsp_syntax.S.Analyzer) +val get_module : Qsp_syntax.Catalog.ex -> (module Qsp_syntax.S.Analyzer) type result -val get : 'a Id.t -> result -> 'a option +val get : 'a Type.Id.t -> result -> 'a option (** The method [get] can be used to get the internal value for one of the - checker used. - *) + checker used. *) module Make (A : sig - val t : t array + val t : Qsp_syntax.Catalog.ex array end) : sig include Qsp_syntax.S.Analyzer with type Location.t = result array end diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml index b467863..918d8e6 100644 --- a/lib/syntax/S.ml +++ b/lib/syntax/S.ml @@ -1,18 +1,16 @@ -(** - This module describe the type an analyzer must implement in order to be - used with the parser. +(** This module describe the type an analyzer must implement in order to be used + with the parser. The module is divided in three modules : - - Expression : the finest part of the QSP syntax. - - Instruction : if/act block, - - Location - *) + - Expression : the finest part of the QSP syntax. + - Instruction : if/act block, + - Location *) -(** {1 Generic types used in the module } *) +(** {1 Generic types used in the module} *) type pos = Lexing.position * Lexing.position -(** The type pos is used to track the starting and ending position for the - given location. *) +(** The type pos is used to track the starting and ending position for the given + location. *) type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option } (** Describe a variable, using the name in capitalized text, and an optionnal @@ -101,7 +99,7 @@ module type Location = sig val location : context -> pos -> instruction list -> t end -(** {1 Unified module used by the parser } *) +(** {1 Unified module used by the parser} *) module type Analyzer = sig val identifier : string @@ -115,7 +113,7 @@ module type Analyzer = sig val is_global : bool (** Declare the checker as global. It requires to run over the whole file and - will be disabled if the application only check a single location. + will be disabled if the application only check a single location. Also, the test will be disabled if a syntax error is reported during the parsing, because this tell that I haven’t been able to analyse the whole @@ -137,11 +135,10 @@ module type Analyzer = sig end (** Helper module used in order to convert elements from the differents - representation levels. + representation levels. Thoses functions are intended to be used in the menhir parser, in order to - limit the code in the mly file. -*) + limit the code in the mly file. *) module Helper (E : sig type t (** Internal type used in the evaluation *) diff --git a/lib/syntax/catalog.ml b/lib/syntax/catalog.ml new file mode 100644 index 0000000..b516976 --- /dev/null +++ b/lib/syntax/catalog.ml @@ -0,0 +1,48 @@ +type ex = + | E : { + module_ : + (module S.Analyzer + with type Expression.t = 'a + and type Expression.t' = 'b + and type Instruction.t = 'c + and type Instruction.t' = 'd + and type Location.t = 'e + and type context = 'f); + expr_witness : 'a Type.Id.t; + expr' : 'b Type.Id.t; + instr_witness : 'c Type.Id.t; + instr' : 'd Type.Id.t; + location_witness : 'e Type.Id.t; + context : 'f Type.Id.t; + } + -> ex (** Type of check to apply *) + +let build : + (module S.Analyzer + with type Expression.t = _ + and type Expression.t' = _ + and type Instruction.t = _ + and type Instruction.t' = _ + and type Location.t = 'a + and type context = _) -> + 'a Type.Id.t * ex = + fun module_ -> + let expr_witness = Type.Id.make () + and expr' = Type.Id.make () + and instr_witness = Type.Id.make () + and instr' = Type.Id.make () + and location_witness = Type.Id.make () + and context = Type.Id.make () in + let t = + E + { + module_; + expr_witness; + expr'; + instr_witness; + instr'; + location_witness; + context; + } + in + (location_witness, t) diff --git a/lib/syntax/catalog.mli b/lib/syntax/catalog.mli new file mode 100644 index 0000000..a256c17 --- /dev/null +++ b/lib/syntax/catalog.mli @@ -0,0 +1,30 @@ +type ex = + | E : { + module_ : + (module S.Analyzer + with type Expression.t = 'a + and type Expression.t' = 'b + and type Instruction.t = 'c + and type Instruction.t' = 'd + and type Location.t = 'e + and type context = 'f); + expr_witness : 'a Type.Id.t; + expr' : 'b Type.Id.t; + instr_witness : 'c Type.Id.t; + instr' : 'd Type.Id.t; + location_witness : 'e Type.Id.t; + context : 'f Type.Id.t; + } + -> ex (** Type of check to apply *) + +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 Type.Id.t * ex +(** 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. *) diff --git a/test/syntax.ml b/test/syntax.ml index 1123101..db449b1 100644 --- a/test/syntax.ml +++ b/test/syntax.ml @@ -4,7 +4,7 @@ module Check = Qsp_checks.Check module S = Qsp_syntax.S module T = Qsp_syntax.T -let location_id, e1 = Check.build (module Tree) +let location_id, e1 = Qsp_syntax.Catalog.build (module Tree) module Parser = Check.Make (struct let t = [| e1 |] @@ -413,7 +413,7 @@ let test_comment_string () = () (** This test ensure that the unary operator is applied to the whole expression - *) +*) let test_precedence () = let index = None in let x = Ast.Ident { Ast.pos = _position; name = "X"; index } @@ -421,8 +421,7 @@ let test_precedence () = _test_instruction "no x = y" Ast.[ Expression (Op (_position, No, BinaryOp (_position, Eq, x, y))) ] -(** This test ensure that a ! is not considered as a comment in an - expression *) +(** This test ensure that a ! is not considered as a comment in an expression *) let test_precedence2 () = let index = None in let x = { Ast.pos = _position; name = "X"; index } @@ -750,8 +749,8 @@ let test_precedence6 () = Ast.Integer (_position, "3") ) )); ] -(** An identifier cannot start by a number *0 is a product and not an - identifier *) +(** An identifier cannot start by a number *0 is a product and not an identifier +*) let test_operator () = let index = None in let a = { Ast.pos = _position; name = "A"; index } @@ -777,10 +776,9 @@ let test_dyneval () = ] (** The parens after input are considered as arguments for the function, not a - following expression. + following expression. - This expression is a boolean. -*) + This expression is a boolean. *) let test_input () = _test_instruction "( input('') = '' )" [ @@ -868,7 +866,7 @@ let test_precedence8 () = Tree.Ast.Integer (_position, "1") ) )); ] -(** Test showing the - should be considered as an operator and cannot be +(** Test showing the - should be considered as an operator and cannot be aggregated inside the integer value. *) let minus_operator () = _test_instruction {|day-7|} |