From 2a2198e91063684a1b19974acc19c25b55266724 Mon Sep 17 00:00:00 2001
From: Chimrod <>
Date: Sun, 22 Oct 2023 07:14:20 +0200
Subject: Refactoring the API

---
 lib/syntax/check.ml | 408 +++++++++++++++++++++++++---------------------------
 1 file changed, 193 insertions(+), 215 deletions(-)

(limited to 'lib/syntax/check.ml')

diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index 3e01e64..10e4809 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -54,26 +54,36 @@ type t =
       module_ :
         (module S.Analyzer
            with type Expression.t = 'a
-            and type Instruction.t = 'b
-            and type Location.t = 'c);
+            and type Expression.t' = 'b
+            and type Instruction.t = 'c
+            and type Instruction.t' = 'd
+            and type Location.t = 'e);
       expr_witness : 'a Id.typeid;
-      instr_witness : 'b Id.typeid;
-      location_witness : 'c Id.typeid;
+      expr' : ('b * Report.t list) Id.typeid;
+      instr_witness : 'c Id.typeid;
+      instr' : ('d * Report.t list) Id.typeid;
+      location_witness : 'e Id.typeid;
     }
       -> t
 
 let build :
     (module S.Analyzer
-       with type Expression.t = 'a
-        and type Instruction.t = 'b
-        and type Location.t = 'c) ->
-    'a Id.typeid * 'b Id.typeid * 'c Id.typeid * t =
+       with type Expression.t = _
+        and type Expression.t' = _
+        and type Instruction.t = _
+        and type Instruction.t' = _
+        and type Location.t = 'a) ->
+    'a Id.typeid * t =
  fun module_ ->
   let expr_witness = Id.newtype ()
+  and expr' = Id.newtype ()
   and instr_witness = Id.newtype ()
+  and instr' = Id.newtype ()
   and location_witness = Id.newtype () in
-  let t = E { module_; expr_witness; instr_witness; location_witness } in
-  (expr_witness, instr_witness, location_witness, t)
+  let t =
+    E { module_; expr_witness; expr'; instr_witness; instr'; location_witness }
+  in
+  (location_witness, t)
 
 module type App = sig
   val t : t array
@@ -82,7 +92,7 @@ end
 module Helper = struct
   type 'a args_list = { witness : 'a Id.typeid; values : 'a S.repr list }
   (** This types helps the compiler to know which kind of arguments are hold
-        inside the list. This is just a list with the additionnal witnesse
+        inside the list. This is just a list with the additionnal witness
         information *)
 
   (** Extract all the lines from the given module 
@@ -97,15 +107,24 @@ module Helper = struct
         ~f:(fun (type a) ({ values; witness } : a args_list) t : a args_list ->
           match get witness (Array.get t i) with
           | None -> failwith "Does not match"
-          | Some value_1 ->
-              { values = (fun r -> (value_1, r)) :: values; witness })
+          | Some value_1 -> { values = (fun _ -> value_1) :: values; witness })
     in
     { result with values = result.values }
 
-  let map_args report args =
-    List.fold_left_map args ~init:report ~f:(fun report v ->
-        let v, result = v report in
-        (result, v))
+  type 'a expr_list = { witness : 'a Id.typeid; values : 'a list }
+
+  let expr_i : result array list -> 'a Id.typeid -> 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 }
+
+  let map_args report args = List.map args ~f:(fun v -> v report)
 end
 
 module Make (A : App) = struct
@@ -113,31 +132,23 @@ module Make (A : App) = struct
     type t = result array
     type t' = result array
 
-    let literal : S.pos -> string -> t S.repr =
-     fun pos value report ->
-      let report, values =
-        Array.fold_left_map A.t ~init:report
-          ~f:(fun report (E { module_ = (module S); expr_witness; _ }) ->
-            let value, report = S.Expression.literal pos value report in
-            (report, R { value; witness = expr_witness }))
-      in
-      (values, report)
-
-    let integer : S.pos -> string -> t S.repr =
-     fun pos value report ->
-      let report, values =
-        Array.fold_left_map A.t ~init:report
-          ~f:(fun report (E { module_ = (module S); expr_witness; _ }) ->
-            let value, report = S.Expression.integer pos value report in
-            (report, R { value; witness = expr_witness }))
-      in
-      (values, report)
+    let literal : S.pos -> string -> t =
+     fun pos value ->
+      Array.map A.t ~f:(fun (E { module_ = (module S); expr_witness; _ }) ->
+          let value = S.Expression.literal pos value in
+          R { value; witness = expr_witness })
+
+    let integer : 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 : S.pos -> T.uoperator -> t S.repr -> t S.repr =
-     fun pos op values report ->
+    let uoperator : S.pos -> T.uoperator -> t -> t =
+     fun pos op values ->
       (* Evaluate the nested expression *)
-      let results, report = values report in
+      let results = values in
 
       (* Now evaluate the remaining expression.
 
@@ -148,7 +159,6 @@ module Make (A : App) = struct
          [fold_left2] and accumulate the report inside the closure, because I
          don’t manage the order of the results.
       *)
-      let report = ref report in
       let results =
         Array.map2 A.t results
           ~f:(fun (E { module_ = (module S); expr_witness; _ }) value ->
@@ -156,26 +166,18 @@ module Make (A : App) = struct
             | None -> failwith "Does not match"
             | Some value ->
                 (* Evaluate the single expression *)
-                let value, report' =
-                  S.Expression.uoperator pos op (fun r -> (value, r)) !report
-                in
-                report := report';
+                let value = S.Expression.uoperator pos op value in
                 R { witness = expr_witness; value })
       in
-      (results, !report)
+      results
 
     (** Basically the same as uoperator, but operate over two operands instead
         of a single one. 
 
         In order to operate over the values (application, op1, op2) I’ve
         written a function [take_arg] which works like a [Array.map3] *)
-    let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
-     fun pos op expr1 expr2 report ->
-      let expr1, report = expr1 report in
-      let expr2, report = expr2 report in
-
-      let report = ref report in
-
+    let boperator : S.pos -> T.boperator -> t -> t -> t =
+     fun pos op expr1 expr2 ->
       let take_arg : result array -> result array -> result array =
        fun expr1 expr2 ->
         let len = Array.length A.t in
@@ -188,189 +190,158 @@ module Make (A : App) = struct
                 get expr_witness (Array.get expr2 i) )
             with
             | Some value_1, Some value_2 ->
-                let value, r =
-                  S.Expression.boperator pos op
-                    (fun r -> (value_1, r))
-                    (fun r -> (value_2, r))
-                    !report
-                in
-                report := r;
+                let value = S.Expression.boperator pos op value_1 value_2 in
                 R { witness = expr_witness; value }
             | _ -> failwith "Does not match")
       in
 
-      let results = take_arg expr1 expr2 in
-      (results, !report)
+      take_arg expr1 expr2
 
     (** Call a function. The functions list is hardcoded in lib/lexer.mll *)
-    let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
-     fun pos func args report ->
-      let report, args = Helper.map_args report args in
-      let report = ref report and len = Array.length A.t in
+    let function_ : S.pos -> T.function_ -> t list -> t =
+     fun pos func args ->
+      let len = Array.length A.t in
       let result =
         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 = Helper.args_i args expr_witness i in
-
-            let value, r =
-              S.Expression.function_ pos func (List.rev args_i.values) !report
-            in
-            report := r;
+            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 })
       in
-      (result, !report)
+      result
 
-    let ident : (S.pos, t S.repr) S.variable -> t S.repr =
-     fun { pos : S.pos; name : string; index : t S.repr option } report ->
+    let ident : (S.pos, t) S.variable -> t =
+     fun { pos : S.pos; name : string; index : t option } ->
       let len = Array.length A.t in
 
-      let report = ref report in
-      let index =
-        Option.map
-          (fun v ->
-            let v, r = v !report in
-            report := r;
-            v)
-          index
-      in
-
+      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' * Report.t list =
+     fun t ->
       let result =
-        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, r =
-                  S.Expression.ident { pos; name; index = None } !report
-                in
-                report := r;
-                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, r =
-                      S.Expression.ident
-                        { pos; name; index = Some (fun r -> (value_1, r)) }
-                        !report
-                    in
-                    report := r;
-                    R { witness = expr_witness; value }))
+        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, !report)
-
-    let v : t * Report.t list -> t' * Report.t list = fun t -> t
+      (result, [])
   end
 
   module Instruction :
     S.Instruction
-      with type expression = Expression.t' S.repr
+      with type expression = Expression.t' * Report.t list
        and type t' = result array = struct
-    type expression = Expression.t' S.repr
+    type expression = Expression.t' * Report.t list
     type t = result array
     type t' = result array
 
     let location : S.pos -> string -> t S.repr =
      fun pos label report ->
-      let report, values =
-        Array.fold_left_map A.t ~init:report
-          ~f:(fun report (E { module_ = (module S); instr_witness; _ }) ->
-            let value, report = S.Instruction.location pos label report in
-
-            (report, R { value; witness = instr_witness }))
+      let values =
+        Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
+            let value = S.Instruction.location pos label report in
+            R { value; witness = instr_witness })
       in
-      (values, report)
+      values
 
     let comment : S.pos -> t S.repr =
      fun pos report ->
-      let report, values =
-        Array.fold_left_map A.t ~init:report
-          ~f:(fun report (E { module_ = (module S); instr_witness; _ }) ->
-            let value, report = S.Instruction.comment pos report in
-
-            (report, R { value; witness = instr_witness }))
+      let values =
+        Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
+            let value = S.Instruction.comment pos report in
+            R { value; witness = instr_witness })
       in
-      (values, report)
+      values
 
     let expression : expression -> t S.repr =
      fun expr report ->
-      let expr, report = expr report in
-      let report = ref report in
+      let expr, _report = expr in
       let results =
         Array.map2 A.t expr
           ~f:(fun
-              (E { module_ = (module S); instr_witness; expr_witness; _ })
-              (R { value; witness })
-            ->
-            match Id.try_cast witness expr_witness with
+              (E { module_ = (module S); instr_witness; expr'; _ }) result ->
+            match get expr' result with
             | None -> failwith "Does not match"
-            | Some Eq ->
+            | Some value ->
                 (* The evaluate the instruction *)
-                let value, r =
-                  S.Instruction.expression
-                    (fun r -> S.Expression.v (value, r))
-                    !report
-                in
-                report := r;
+                let value = S.Instruction.expression value report in
                 R { value; witness = instr_witness })
       in
-      (results, !report)
+      results
 
     let call : S.pos -> T.keywords -> expression list -> t S.repr =
      fun pos keyword args report ->
-      let report, args = Helper.map_args report args in
-      let report = ref report and len = Array.length A.t in
+      (* The arguments are given like an array of array. Each expression is
+         actually the list of each expression in the differents modules. *)
+
+      (* Accumulate the results *)
+      let report, args =
+        List.fold_left_map args ~init:report ~f:(fun report (v, r) ->
+            (r @ report, v))
+      in
+
+      let len = Array.length A.t in
       let result =
         Array.init len ~f:(fun i ->
-            let (E { module_ = (module S); expr_witness; instr_witness; _ }) =
+            let (E { module_ = (module S); expr'; instr_witness; _ }) =
               Array.get A.t i
             in
-            let args_i = Helper.args_i args expr_witness i in
-            let values =
-              List.rev_map args_i.values ~f:(fun value r ->
-                  S.Expression.v (value r))
-            in
 
-            let value, r = S.Instruction.call pos keyword values !report in
-            report := r;
+            let values = List.rev (Helper.expr_i args expr' i).values in
+
+            let value = S.Instruction.call pos keyword values report in
             R { witness = instr_witness; value })
       in
-      (result, !report)
+      result
 
     let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
-     fun pos ~label instructions report ->
-      let label, report = label report in
-      let report, instructions = Helper.map_args report instructions in
-      let report = ref report and len = Array.length A.t in
+     fun pos ~label instructions _report ->
+      let label, report = label in
+      let instructions = Helper.map_args report instructions in
+      let len = Array.length A.t in
 
       let result =
         Array.init len ~f:(fun i ->
-            let (E { module_ = (module S); instr_witness; expr_witness; _ }) =
+            let (E { module_ = (module S); instr_witness; expr'; _ }) =
               Array.get A.t i
             in
-            let args_i = Helper.args_i instructions instr_witness i in
             let values =
-              List.rev_map args_i.values ~f:(fun value r -> value r)
+              List.rev (Helper.args_i instructions instr_witness i).values
             in
 
-            match get expr_witness (Array.get label i) with
+            match get expr' (Array.get label i) with
             | None -> failwith "Does not match"
             | Some label_i ->
-                let label_i r = S.Expression.v (label_i, r) in
-                let value, r =
-                  S.Instruction.act pos ~label:label_i values !report
+                let value =
+                  S.Instruction.act pos ~label:label_i values report
                 in
-                report := r;
                 R { witness = instr_witness; value })
       in
 
-      (result, !report)
+      result
 
     (* I think it’s one of the longest module I’ve ever written in OCaml… *)
 
@@ -380,14 +351,14 @@ module Make (A : App) = struct
         T.assignation_operator ->
         expression ->
         t S.repr =
-     fun pos { pos = var_pos; name; index } op expression report ->
-      let expression, report = expression report in
+     fun pos { pos = var_pos; name; index } op expression _report ->
+      let expression, report = expression in
       let report = ref report and len = Array.length A.t in
 
       let index =
         Option.map
           (fun v ->
-            let v, r = v !report in
+            let v, r = v in
             report := r;
             v)
           index
@@ -395,49 +366,44 @@ module Make (A : App) = struct
 
       let result =
         Array.init len ~f:(fun i ->
-            let (E { module_ = (module A); instr_witness; expr_witness; _ }) =
+            let (E { module_ = (module A); instr_witness; expr'; _ }) =
               Array.get A.t i
             in
 
             let index_i =
               Option.map
                 (fun expression ->
-                  match get expr_witness (Array.get expression i) with
+                  match get expr' (Array.get expression i) with
                   | None -> failwith "Does not match"
-                  | Some value ->
-                      let value r = A.Expression.v (value, r) in
-                      value)
+                  | Some value -> value)
                 index
             in
             let variable = S.{ pos = var_pos; name; index = index_i } in
 
-            match get expr_witness (Array.get expression i) with
+            match get expr' (Array.get expression i) with
             | None -> failwith "Does not match"
             | Some value ->
-                let value, r =
-                  A.Instruction.assign pos variable op
-                    (fun r -> A.Expression.v (value, r))
-                    !report
+                let value =
+                  A.Instruction.assign pos variable op value !report
                 in
-                report := r;
 
                 R { value; witness = instr_witness })
       in
 
-      (result, !report)
+      result
 
     (** Helper function used to prepare the clauses *)
     let map_clause :
         Report.t list ->
         (expression, t) S.clause ->
         Report.t list * (S.pos * Expression.t' * t list) =
-     fun report clause ->
+     fun _report clause ->
       let clause_pos, expression, t = clause in
-      let expression, report = expression report in
-      let report, t =
-        List.fold_left_map t ~init:report ~f:(fun report t ->
-            let t, report = t report in
-            (report, t))
+      let expression, report = expression in
+      let t =
+        List.map t ~f:(fun t ->
+            let t = t report in
+            t)
       in
       let clause = (clause_pos, expression, t) in
       (report, clause)
@@ -450,13 +416,13 @@ module Make (A : App) = struct
         (b -> 'c) ->
         S.pos * result array * result array list ->
         ('c, a) S.clause =
-     fun i instr_witness expr_witness f clause ->
+     fun i instr_witness expr' f clause ->
       let pos_clause, expr_clause, ts = clause in
-      match get expr_witness (Array.get expr_clause i) with
+      match get expr' (Array.get expr_clause i) with
       | None -> failwith "Does not match"
       | Some value ->
           let ts = Helper.args_i ts instr_witness i in
-          let ts = List.rev_map ts.values ~f:(fun value r -> value r) in
+          let ts = List.rev ts.values in
           let clause = (pos_clause, f value, ts) in
           clause
 
@@ -469,28 +435,29 @@ module Make (A : App) = struct
      fun pos clause ~elifs ~else_ report ->
       (* First, apply the report for all the instructions *)
       let report, clause = map_clause report clause in
+
       let report, elifs = List.fold_left_map elifs ~init:report ~f:map_clause in
       let report, else_ =
         match else_ with
         | None -> (report, None)
         | Some (pos, instructions) ->
-            let report, instructions = Helper.map_args report instructions in
+            let instructions = Helper.map_args report instructions in
             (report, Some (pos, instructions))
       in
-      let report = ref report and len = Array.length A.t in
+      let len = Array.length A.t in
 
       let result =
         Array.init len ~f:(fun i ->
-            let (E { module_ = (module A); instr_witness; expr_witness; _ }) =
+            let (E { module_ = (module A); instr_witness; expr'; _ }) =
               Array.get A.t i
             in
 
             (* This function helps to build the expression in the clauses *)
-            let f v r = A.Expression.v (v, r) in
+            let f = Fun.id in
 
-            let clause = rebuild_clause i instr_witness expr_witness f clause
+            let clause = rebuild_clause i instr_witness expr' f clause
             and elifs =
-              List.map elifs ~f:(rebuild_clause i instr_witness expr_witness f)
+              List.map elifs ~f:(rebuild_clause i instr_witness expr' f)
             and else_ =
               match else_ with
               | None -> None
@@ -499,45 +466,56 @@ module Make (A : App) = struct
                   Some (pos, List.rev elses.values)
             in
 
-            let value, r = A.Instruction.if_ pos clause ~elifs ~else_ !report in
-            report := r;
+            let value = A.Instruction.if_ pos clause ~elifs ~else_ report in
             R { value; witness = instr_witness })
       in
 
-      (result, !report)
+      result
 
-    let v : t * Report.t list -> t' * Report.t list = fun t -> t
+    (** This code is almost a copy/paste from Expression.v but I did not found
+        a way to factorize it. *)
+    let v : t -> t' * Report.t list =
+     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 :
-    S.Location with type t = result array and type instruction = Instruction.t' =
-  struct
-    type instruction = Instruction.t'
+    S.Location
+      with type t = result array
+       and type instruction = (Instruction.t' * Report.t list) S.repr = struct
+    type instruction = (Instruction.t' * Report.t list) S.repr
     type t = result array
 
-    let location : S.pos -> instruction S.repr list -> t S.repr =
+    let location : S.pos -> instruction list -> (t * Report.t list) S.repr =
      fun pos instructions report ->
       ignore pos;
 
-      let report, instructions = Helper.map_args report instructions in
+      (* Extract the instructions and accumulate the result *)
+      let instructions = Helper.map_args report instructions in
+
+      let report, args =
+        List.fold_left_map instructions ~init:report ~f:(fun report (v, r) ->
+            (r @ report, v))
+      in
 
       let report = ref report and len = Array.length A.t in
       let result =
         Array.init len ~f:(fun i ->
-            let (E { module_ = (module A); instr_witness; location_witness; _ })
-                =
+            let (E { module_ = (module A); instr'; location_witness; _ }) =
               Array.get A.t i
             in
 
-            let instructions_i : A.Instruction.t Helper.args_list =
-              Helper.args_i instructions instr_witness i
-            in
-            let inst : A.Instruction.t S.repr list = instructions_i.values in
-            let instructions : A.Instruction.t' S.repr list =
-              List.rev_map inst ~f:(fun value report ->
-                  let value, report = value report in
-                  A.Instruction.v (value, report))
-            in
+            let instructions = List.rev (Helper.args_i args instr' i).values in
             let value, re = A.Location.location pos instructions !report in
             report := re;
             R { value; witness = location_witness })
-- 
cgit v1.2.3