aboutsummaryrefslogtreecommitdiff
path: root/lib/checks
diff options
context:
space:
mode:
Diffstat (limited to 'lib/checks')
-rw-r--r--lib/checks/check.ml163
-rw-r--r--lib/checks/check.mli64
2 files changed, 72 insertions, 155 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-18 09:15:42 +0000