Moved the checks in a dedicated library

1 files changed, 433 insertions, 0 deletions

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