From 65164f2ebe61a566d96119c2cde23eee6771007b Mon Sep 17 00:00:00 2001 From: Chimrod <> Date: Mon, 9 Dec 2024 10:13:50 +0100 Subject: Splitted the code and declare the test catalog in it’s own module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/checks/check.ml | 163 ++++++++++++++++++------------------------------- lib/checks/check.mli | 64 ++++--------------- lib/syntax/S.ml | 27 ++++---- lib/syntax/catalog.ml | 48 +++++++++++++++ lib/syntax/catalog.mli | 30 +++++++++ 5 files changed, 162 insertions(+), 170 deletions(-) create mode 100644 lib/syntax/catalog.ml create mode 100644 lib/syntax/catalog.mli (limited to 'lib') 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. *) -- cgit v1.2.3