Added dependencies system between the modules in the checksHEADmaster

1 files changed, 258 insertions, 98 deletions

diff --git a/lib/checks/check.ml b/lib/checks/check.ml
index 6169bb1..597bc0a 100644
--- a/lib/checks/check.ml
+++ b/lib/checks/check.ml
@@ -1,5 +1,4 @@
 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. *)
@@ -11,10 +10,13 @@ let get : type a. a Type.Id.t -> result -> a option =
   | Some Type.Equal -> Some value
   | None -> None
 
-type t = Qsp_syntax.Catalog.ex
+let set : type a. a Type.Id.t -> result -> a -> result option =
+ fun typeid (R { witness; _ }) value ->
+  match Type.Id.provably_equal typeid witness with
+  | Some Type.Equal -> Some (R { witness; value })
+  | None -> None
 
-let get_module : t -> (module S.Analyzer) =
- fun (E { module_; _ }) -> (module_ :> (module S.Analyzer))
+type t = Qsp_syntax.Identifier.t
 
 module type App = sig
   val t : t array
@@ -42,23 +44,85 @@ module Make (A : App) = struct
   let description = "Internal module"
   let is_global = false
   let active = ref false
+  let depends = [] (* This modules depends of nothing *)
+
+  type ex = Qsp_syntax.Identifier.t
 
   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 the modules to check here, at the module level *)
+  let checks =
+    (* Collect all the dependencies and build the execution order *)
+    let graph : ex list =
+      let rec build_deps l acc =
+        List.fold_left
+          (l : ex list)
+          ~init:acc
+          ~f:(fun
+              acc (Qsp_syntax.Identifier.E { module_ = (module S); _ } as ex) ->
+            let acc' = ex :: acc in
+
+            build_deps S.depends acc')
+      in
+      build_deps (Array.to_list A.t) []
+    in
+
+    (* Convert the dependenciees using the module identifier only, the
+       Tsort.sort function use structural equality comparaison function which
+       does not wok with the module embeded in first class module.  *)
+    let graph_name =
+      List.map graph
+        ~f:(fun (Qsp_syntax.Identifier.E { module_ = (module S); _ }) ->
+          let deps' =
+            List.map
+              ~f:(fun (Qsp_syntax.Identifier.E { module_ = (module S); _ }) ->
+                S.identifier)
+              S.depends
+          in
+          (S.identifier, deps'))
+    in
+    match Tsort.sort graph_name with
+    | Tsort.Sorted sorted_graph ->
+        (* From the identifier, extract the associated check *)
+        let _ =
+          List.map sorted_graph ~f:(fun name ->
+              List.find_map graph
+                ~f:(fun
+                    (Qsp_syntax.Identifier.E { module_ = (module S); _ } as
+                     check)
+                  ->
+                  match String.equal name S.identifier with
+                  | false -> None
+                  | true -> Some check)
+              |> Option.get)
+          (* It’s ok to use unchecked option.get here, because the list was
+               created from the same source just before *)
+        in
+
+        Array.of_list graph
+    | Tsort.ErrorCycle _ ->
+        (* This is very unlikely to happen, as it would reflect an error in
+           the compilation units order *)
+        raise Not_found
+
   (** Initialize each test, and keep the result in the context. *)
   let initialize : unit -> context =
    fun () ->
-    Array.map A.t ~f:(fun (C.E { module_ = (module S); context; _ }) ->
+    Array.map checks
+      ~f:(fun (Qsp_syntax.Identifier.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) (C.E { module_ = (module S); context; _ }) ->
+      Array.fold_left checks ~init:(0, [])
+        ~f:(fun
+            (i, acc)
+            (Qsp_syntax.Identifier.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
@@ -67,111 +131,195 @@ module Make (A : App) = struct
     report
 
   (* Global variable for the whole module *)
-  let len = Array.length A.t
+  let len = Array.length checks
 
   module Expression : S.Expression with type t' = result array = struct
     type t = result array
     type t' = result array
 
-    let literal : S.pos -> t Qsp_syntax.T.literal list -> t =
-     fun pos values ->
-      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
-              ~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 : S.pos -> string -> t =
-     fun pos value ->
-      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 })
+    let build_ctx : result option array -> Qsp_syntax.S.extract_context =
+     fun results ->
+      {
+        f =
+          (fun id ->
+            Array.find_map results ~f:(function
+              | Some result -> get id result
+              | None -> None));
+      }
+
+    let literal :
+        ctx:Qsp_syntax.S.extract_context ->
+        S.pos ->
+        t Qsp_syntax.T.literal list ->
+        t =
+     fun ~ctx pos values ->
+      ignore ctx;
+      let results = Array.make len None in
+      (* Create the new array, filled with None at the begining.
+
+         Then populate the array in place in order to read the previous values
+         if requested *)
+      (* Extract the result with the given ID from the array *)
+      let ctx = build_ctx results in
+      let () =
+        Array.mapi_inplace results ~f:(fun i _ ->
+            let (Qsp_syntax.Identifier.E
+                   { module_ = (module S); expr_witness; _ }) =
+              Array.get checks i
+            in
+            (* 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 ~ctx pos values' in
+            Some (R { value; witness = expr_witness }))
+      in
+      Array.map results ~f:Option.get
 
-    (** Unary operator like [-123] or [+'Text']*)
-    let uoperator : S.pos -> Qsp_syntax.T.uoperator -> t -> t =
-     fun pos op values ->
-      (* Evaluate the nested expression *)
-      let results = values in
+    let integer : ctx:Qsp_syntax.S.extract_context -> S.pos -> string -> t =
+     fun ~ctx pos value ->
+      ignore ctx;
+      let results = Array.make len None in
+      let ctx = build_ctx results in
 
-      (* Now evaluate the remaining expression.
+      let () =
+        Array.mapi_inplace results ~f:(fun i _ ->
+            let (Qsp_syntax.Identifier.E
+                   { module_ = (module S); expr_witness; _ }) =
+              Array.get checks i
+            in
+            let value = S.Expression.integer ~ctx pos value in
+            Some (R { value; witness = expr_witness }))
+      in
+      Array.map results ~f:Option.get
 
-         Traverse both the module the apply, and the matching expression already
-         evaluated.
+    (** Unary operator like [-123] or [+'Text']*)
+    let uoperator :
+        ctx:Qsp_syntax.S.extract_context ->
+        S.pos ->
+        Qsp_syntax.T.uoperator ->
+        t ->
+        t =
+     fun ~ctx pos op values ->
+      ignore ctx;
+      let results = Array.make len None in
+      let ctx = build_ctx results in
 
-         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 (C.E { module_ = (module S); expr_witness; _ }) value ->
+      (* Evaluate the nested expression *)
+      let () =
+        Array.mapi_inplace results ~f:(fun i _ ->
+            let (Qsp_syntax.Identifier.E
+                   { module_ = (module S); expr_witness; _ }) =
+              Array.get checks i
+            in
+            let value = Array.get values i in
             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 })
+                let value = S.Expression.uoperator ~ctx pos op value in
+                Some (R { witness = expr_witness; value }))
       in
-      results
+      Array.map results ~f:Option.get
 
     (** Basically the same as uoperator, but operate over two operands instead
         of a single one. *)
-    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
-          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")
+    let boperator :
+        ctx:Qsp_syntax.S.extract_context ->
+        S.pos ->
+        Qsp_syntax.T.boperator ->
+        t ->
+        t ->
+        t =
+     fun ~ctx pos op expr1 expr2 ->
+      ignore ctx;
+      let results = Array.make len None in
+      let ctx = build_ctx results in
+      let () =
+        Array.mapi_inplace results ~f:(fun i _ ->
+            let (E { module_ = (module S); expr_witness; _ }) =
+              Array.get checks 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 ~ctx pos op value_1 value_2
+                in
+                Some (R { witness = expr_witness; value })
+            | _ -> failwith "Does not match")
+      in
+      Array.map results ~f:Option.get
 
     (** Call a function. The functions list is hardcoded in lib/lexer.mll *)
-    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
-          (* 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 }))
+    let function_ :
+        ctx:Qsp_syntax.S.extract_context ->
+        S.pos ->
+        Qsp_syntax.T.function_ ->
+        t list ->
+        t =
+     fun ~ctx pos func args ->
+      ignore ctx;
+      let results = Array.make len None in
+      let ctx = build_ctx results in
+      let () =
+        Array.mapi_inplace results ~f:(fun i _ ->
+            let (E { module_ = (module S); expr_witness; _ }) =
+              Array.get checks 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_ ~ctx pos func args_i in
+            Some (R { witness = expr_witness; value }))
+      in
+      Array.map results ~f:Option.get
+
+    let ident : ctx:Qsp_syntax.S.extract_context -> (S.pos, t) S.variable -> t =
+     fun ~ctx { pos : S.pos; name : string; index : t option } ->
+      ignore ctx;
+      let results = Array.make len None in
+      let ctx = build_ctx results in
+      let () =
+        Array.mapi_inplace results ~f:(fun i _ ->
+            let (E { module_ = (module S); expr_witness; _ }) =
+              Array.get checks i
+            in
+
+            match index with
+            | None ->
+                (* Easest case, just return the plain ident *)
+                let value =
+                  S.Expression.ident ~ctx { pos; name; index = None }
+                in
+                Some (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 ~ctx
+                        { pos; name; index = Some value_1 }
+                    in
+                    Some (R { witness = expr_witness; value })))
+      in
+      Array.map results ~f:Option.get
 
     (** Convert each internal represention for the expression into its external
         representation *)
     let v : t -> t' =
      fun t ->
       let result =
-        Array.map2 A.t t
+        Array.map2 checks t
           ~f:(fun
-              (C.E { module_ = (module S); expr_witness; expr'; _ }) result ->
+              (Qsp_syntax.Identifier.E
+                 { module_ = (module S); expr_witness; expr'; _ })
+              result
+            ->
             match get expr_witness result with
             | None -> failwith "Does not match"
             | Some value ->
@@ -191,21 +339,30 @@ module Make (A : App) = struct
 
     let location : S.pos -> string -> t =
      fun pos label ->
-      Array.map A.t ~f:(fun (C.E { module_ = (module S); instr_witness; _ }) ->
+      Array.map checks
+        ~f:(fun
+            (Qsp_syntax.Identifier.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 (C.E { module_ = (module S); instr_witness; _ }) ->
+      Array.map checks
+        ~f:(fun
+            (Qsp_syntax.Identifier.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
+      Array.map2 checks expr
         ~f:(fun
-            (C.E { module_ = (module S); instr_witness; expr'; _ }) result ->
+            (Qsp_syntax.Identifier.E
+               { module_ = (module S); instr_witness; expr'; _ })
+            result
+          ->
           match get expr' result with
           | None -> failwith "Does not match"
           | Some value ->
@@ -219,7 +376,7 @@ module Make (A : App) = struct
          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
+            Array.get checks i
           in
 
           let values = List.rev (Helper.expr_i args expr' i).values in
@@ -231,7 +388,7 @@ module Make (A : App) = struct
      fun pos ~label instructions ->
       Array.init len ~f:(fun i ->
           let (E { module_ = (module S); instr_witness; expr'; _ }) =
-            Array.get A.t i
+            Array.get checks i
           in
           let values =
             List.rev (Helper.expr_i instructions instr_witness i).values
@@ -254,7 +411,7 @@ module Make (A : App) = struct
      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
+            Array.get checks i
           in
 
           let index_i =
@@ -303,7 +460,7 @@ module Make (A : App) = struct
       in
       Array.init len ~f:(fun i ->
           let (E { module_ = (module A); instr_witness; expr'; _ }) =
-            Array.get A.t i
+            Array.get checks i
           in
 
           let clause = rebuild_clause i instr_witness expr' clause
@@ -324,9 +481,12 @@ module Make (A : App) = struct
     let v : t -> t' =
      fun t ->
       let result =
-        Array.map2 A.t t
+        Array.map2 checks t
           ~f:(fun
-              (C.E { module_ = (module S); instr_witness; instr'; _ }) result ->
+              (Qsp_syntax.Identifier.E
+                 { module_ = (module S); instr_witness; instr'; _ })
+              result
+            ->
             match get instr_witness result with
             | None -> failwith "Does not match"
             | Some value ->
@@ -358,7 +518,7 @@ module Make (A : App) = struct
                      context;
                      _;
                    }) =
-              Array.get A.t i
+              Array.get checks i
             in
 
             let local_context =
@@ -377,7 +537,7 @@ module Make (A : App) = struct
       let () =
         Array.iteri args ~f:(fun i result ->
             let (E { module_ = (module A); location_witness; _ }) =
-              Array.get A.t i
+              Array.get checks i
             in
             match get location_witness result with
             | None -> failwith "Does not match"