Used the dead-end checker in main analysis

1 files changed, 141 insertions, 26 deletions

diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index bb78263..36c997f 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -1,53 +1,168 @@
 open StdLabels
 
-type pos = Lexing.position * Lexing.position
-type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option }
+module Expression = struct
+  type t = unit
+  type t' = unit
 
-module Expression = Default.Expression
+  include Default.Expression (struct
+    type nonrec t = t
+
+    let default = ()
+  end)
+
+  let v : t * Report.t list -> t' * Report.t list = Fun.id
+end
 
 module Instruction = struct
-  type expression = Default.Expression.t' S.repr
-  type repr = unit
+  type expression = Expression.t' S.repr
+  type cause = Missing_else | Unchecked_path
+
+  type t = {
+    block_pos : S.pos;
+    has_gt : bool;
+    is_gt : bool;
+    pos : (cause * S.pos) option;
+  }
+
+  type t' = t
+
+  (** For each instruction, return thoses two informations :
+
+      - the intruction contains at [gt] 
+      - the last instruction is a [gt]
+
+    *)
+  let v : t * Report.t list -> t' * Report.t list = Fun.id
+
+  let default =
+    {
+      block_pos = (Lexing.dummy_pos, Lexing.dummy_pos);
+      has_gt = false;
+      is_gt = false;
+      pos = None;
+    }
 
   (** Call for an instruction like [GT] or [*CLR] *)
-  let call : pos -> string -> expression list -> repr = fun _ _ _ -> ()
+  let call : S.pos -> T.keywords -> expression list -> t S.repr =
+   fun pos f _ report ->
+    ignore pos;
+    match f with
+    | T.Goto | T.XGoto ->
+        ({ block_pos = pos; has_gt = true; is_gt = true; pos = None }, report)
+    | T.Gosub ->
+        ({ block_pos = pos; has_gt = false; is_gt = true; pos = None }, report)
+    | _ -> (default, report)
 
   (** Label for a loop *)
-  let location : pos -> string -> repr = fun _ _ -> ()
+  let location : S.pos -> string -> t S.repr =
+   fun _ _ report -> (default, report)
 
   (** Comment *)
-  let comment : pos -> repr = fun _ -> ()
+  let comment : S.pos -> t S.repr = fun _ report -> (default, report)
 
   (** Raw expression *)
-  let expression : expression -> repr = fun _ -> ()
+  let expression : expression -> t S.repr = fun _ report -> (default, report)
+
+  (** The content of a block is very linear, I only need to check the last element *)
+  let check_block : S.pos -> t S.repr list -> t S.repr =
+   fun pos instructions report ->
+    let last_element =
+      List.fold_left instructions ~init:(default, report)
+        ~f:(fun (t, report) instruction ->
+          let result, report = instruction report in
+          let has_gt = result.has_gt || t.has_gt in
+          let is_gt = result.is_gt || t.is_gt in
+          ({ result with block_pos = pos; is_gt; has_gt }, report))
+    in
+    last_element
+
+  let if_ :
+      S.pos ->
+      (expression, t) S.clause ->
+      elifs:(expression, t) S.clause list ->
+      else_:(S.pos * t S.repr list) option ->
+      t S.repr =
+   fun pos clause ~elifs ~else_ report ->
+    (* For each block, evaluate the instructions *)
+    let report, res, has_gt, is_gt =
+      List.fold_left ~init:(report, [], false, false) (clause :: elifs)
+        ~f:(fun (report, acc, has_gt, is_gt) clause ->
+          let pos, _, instructions = clause in
+          let clause_t, report = check_block pos instructions report in
+          let has_gt = has_gt || clause_t.has_gt
+          and is_gt = is_gt || clause_t.is_gt in
 
-  type clause = pos * expression * repr list
+          (report, (clause_t, pos) :: acc, has_gt, is_gt))
+    in
 
-  let if_ : pos -> clause -> elifs:clause list -> else_:repr list -> repr =
-   fun _ _ ~elifs ~else_ ->
-    ignore elifs;
-    ignore else_;
-    ()
+    let else_pos, else_block, report =
+      match else_ with
+      | Some (pos, instructions) ->
+          let block, report = check_block pos instructions report in
+          (pos, block, report)
+      | None -> (pos, default, report)
+    in
+    let has_gt = has_gt || else_block.has_gt
+    and is_gt = is_gt || else_block.is_gt in
 
-  let act : pos -> label:expression -> repr list -> repr =
-   fun _ ~label _ ->
+    let blocks = (else_block, else_pos) :: res in
+
+    (* Check if one of the clauses already holds a dead end*)
+    match List.find_opt res ~f:(fun (res, _) -> res.pos != None) with
+    | Some (v, _) -> (v, report)
+    | None -> (
+        match (is_gt, has_gt) with
+        | _, true -> (
+            (* There is gt intruction in one of the branch, we need to checks
+               the others *)
+            match List.find_opt blocks ~f:(fun (f, _) -> not f.is_gt) with
+            | None ->
+                (* Every branch in the if is covered. It’s ok. *)
+                ({ default with block_pos = pos; is_gt; has_gt }, report)
+            | Some (_, pos) ->
+                (* TODO check if [pos] is the whole block *)
+                let cause =
+                  match else_ with None -> Missing_else | _ -> Unchecked_path
+                in
+                ( { default with block_pos = pos; pos = Some (cause, pos) },
+                  report ))
+        | _, _ -> ({ default with block_pos = pos; has_gt; is_gt }, report))
+
+  let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
+   fun pos ~label expressions report ->
     ignore label;
-    ()
+    check_block pos expressions report
 
   let assign :
-      pos ->
+      S.pos ->
       (S.pos, expression) S.variable ->
       T.assignation_operator ->
       expression ->
-      repr =
-   fun _ _ _ _ -> ()
+      t S.repr =
+   fun _ _ _ _ report -> (default, report)
 end
 
 module Location = struct
-  type repr = Instruction.repr
-  type instruction = Instruction.repr
+  type t = unit
+  type instruction = Instruction.t
+
+  let location : S.pos -> instruction S.repr list -> t S.repr =
+   fun _pos instructions report ->
+    ( (),
+      List.fold_left instructions ~init:report ~f:(fun report instruction ->
+          let t, report = instruction report in
 
-  let location : pos -> instruction list -> repr =
-   fun _pos instructions ->
-    List.fold_left instructions ~init:() ~f:(fun () instruction -> instruction)
+          match (t.Instruction.is_gt, t.Instruction.pos) with
+          | false, Some (cause, value) ->
+              ignore cause;
+              if t.Instruction.block_pos != value then
+                match cause with
+                | Missing_else ->
+                    Report.debug value "Possible dead end (no else fallback)"
+                    :: report
+                | Unchecked_path ->
+                    Report.warn value "Possible dead end (unmatched path)"
+                    :: report
+              else report
+          | _ -> report) )
 end