Used the dead-end checker in main analysis

13 files changed, 352 insertions, 67 deletions

diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml
index 93f44f4..8ab442b 100644
--- a/bin/qsp_parser.ml
+++ b/bin/qsp_parser.ml
@@ -20,9 +20,10 @@ type ctx = { error_nb : int; warn_nb : int; debug_nb : int }
     List all the controls to apply 
  *)
 let _, _, _, e1 = Qsp_syntax.Check.build (module Qsp_syntax.Type_of)
+let _, _, _, e2 = Qsp_syntax.Check.build (module Qsp_syntax.Dead_end)
 
 module Check = Qsp_syntax.Check.Make (struct
-  let t = [| e1 |]
+  let t = [| e1; e2 |]
 end)
 
 (** Read the source file until getting a report (the whole location has been
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index fd3f85b..63b9577 100644
--- a/lib/qparser/parser.mly
+++ b/lib/qparser/parser.mly
@@ -10,9 +10,9 @@
          -> Analyzer.Expression.t' * Qsp_syntax.Report.t list 
         ; body : Analyzer.Instruction.t Qsp_syntax.S.repr list
         ; pos : Qsp_syntax.S.pos
-        ; else_ : (
+        ; clauses : (
             ( (Analyzer.Instruction.expression, Analyzer.Instruction.t) Qsp_syntax.S.clause list 
-            * Analyzer.Instruction.t Qsp_syntax.S.repr list
+            * (Qsp_syntax.S.pos *Analyzer.Instruction.t Qsp_syntax.S.repr list) option
             ) option )
         }
 
@@ -49,9 +49,9 @@ line_statement:
     | s = terminated(inline_action, line_sep)
         { s }
     | a = action_bloc(IF, elif_else_body) 
-    { let {loc; expression; body; pos; else_ } = a in 
-        let elifs, else_ = match else_ with 
-        | None -> [], []
+    { let {loc; expression; body; pos; clauses } = a in 
+        let elifs, else_ = match clauses with 
+        | None -> [], None
         | Some (elifs, else_) -> (elifs, else_)
         in
         Analyzer.Instruction.if_
@@ -78,9 +78,9 @@ line_statement:
       line_sep
       { 
         let expression = Helper.v e in
-        let else_ = match b with
+        let clauses = match b with
         | None -> None
-        | Some (elifs, else_) -> 
+        | Some (elifs, clauses) -> 
             let elifs = begin match elifs with 
             | [] -> []
             | _ -> 
@@ -91,13 +91,13 @@ line_statement:
               )
 
             end in
-          Some (elifs, else_)
+          Some (elifs, clauses)
         in 
 
         { loc = $loc 
         ; expression
         ; body = s
-        ; else_ = else_
+        ; clauses
         ; pos = $loc(s)
         }
       }
@@ -115,8 +115,8 @@ elif:
 else_:
     | ELSE EOL+
       expressions = line_statement*
-      { expressions }
-    | { [] }
+      { Some ($loc, expressions) }
+    | { None }
 
 
 elif_else_body: 
diff --git a/lib/qparser/qsp_instruction.mly b/lib/qparser/qsp_instruction.mly
index fe8a51a..8272cff 100644
--- a/lib/qparser/qsp_instruction.mly
+++ b/lib/qparser/qsp_instruction.mly
@@ -25,7 +25,9 @@ argument(X):
       else_opt = preceded(ELSE, instruction)?
       { let loc, expr, statements, loc_s, _body = a in 
         let elifs = []
-        and else_ = Option.to_list else_opt in
+        and else_ = match else_opt with 
+          | None -> None
+          | Some instructions -> Some ($loc(else_opt), [ instructions ]) in
         Analyzer.Instruction.if_
             loc 
             (loc_s, Helper.v expr, statements) 
@@ -33,10 +35,10 @@ argument(X):
             ~else_
       }
     | a = onliner(IF)
-      else_= preceded(ELSE, inline_action)
+      else_ = preceded(ELSE, inline_action)
       { let loc, expr, statements, loc_s, _body = a in 
         let elifs = []
-        and else_ = [ else_ ] in
+        and else_ = Some ($loc(else_), [ else_ ]) in
 
         Analyzer.Instruction.if_
             loc 
diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index 3d86881..710eb59 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -81,7 +81,7 @@ module type Instruction = sig
     pos ->
     (expression, t) clause ->
     elifs:(expression, t) clause list ->
-    else_:t repr list ->
+    else_:(pos * t repr list) option ->
     t repr
 
   val act : pos -> label:expression -> t repr list -> t repr
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index 3e9d255..3e01e64 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -464,13 +464,19 @@ module Make (A : App) = struct
         S.pos ->
         (expression, t) S.clause ->
         elifs:(expression, t) S.clause list ->
-        else_:t S.repr list ->
+        else_:(S.pos * t S.repr list) option ->
         t S.repr =
      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_ = Helper.map_args report else_ in
+      let report, else_ =
+        match else_ with
+        | None -> (report, None)
+        | Some (pos, instructions) ->
+            let report, instructions = Helper.map_args report instructions in
+            (report, Some (pos, instructions))
+      in
       let report = ref report and len = Array.length A.t in
 
       let result =
@@ -485,9 +491,13 @@ module Make (A : App) = struct
             let clause = rebuild_clause i instr_witness expr_witness f clause
             and elifs =
               List.map elifs ~f:(rebuild_clause i instr_witness expr_witness f)
-            and elses = Helper.args_i else_ instr_witness i in
-
-            let else_ = List.rev elses.values in
+            and else_ =
+              match else_ with
+              | None -> None
+              | Some (pos, instructions) ->
+                  let elses = Helper.args_i instructions instr_witness i in
+                  Some (pos, List.rev elses.values)
+            in
 
             let value, r = A.Instruction.if_ pos clause ~elifs ~else_ !report in
             report := r;
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
diff --git a/lib/syntax/dead_end.mli b/lib/syntax/dead_end.mli
new file mode 100644
index 0000000..ce48791
--- /dev/null
+++ b/lib/syntax/dead_end.mli
@@ -0,0 +1 @@
+include S.Analyzer with type Location.t = unit
diff --git a/lib/syntax/default.ml b/lib/syntax/default.ml
index eed7f2b..dad5144 100644
--- a/lib/syntax/default.ml
+++ b/lib/syntax/default.ml
@@ -3,7 +3,13 @@
 This module is expected to be used when you only need to implement an analyze
 over a limited part of the whole syntax. *)
 
-module Expression = struct
+module type T = sig
+  type t
+
+  val default : t
+end
+
+module Expression (T' : T) = struct
   (** 
       Describe a variable, using the name in capitalized text, and an optionnal
       index.
@@ -11,28 +17,29 @@ module Expression = struct
       If missing, the index should be considered as [0].
    *)
 
-  type t = unit
-  type t' = unit
-
-  let ident : (S.pos, t S.repr) S.variable -> t S.repr =
-   fun _ report -> ((), report)
+  let ident : (S.pos, T'.t S.repr) S.variable -> T'.t S.repr =
+   fun _ report -> (T'.default, report)
 
   (*
         Basic values, text, number…
    *)
 
-  let integer : S.pos -> string -> t S.repr = fun _ _ report -> ((), report)
-  let literal : S.pos -> string -> t S.repr = fun _ _ report -> ((), report)
+  let integer : S.pos -> string -> T'.t S.repr =
+   fun _ _ report -> (T'.default, report)
+
+  let literal : S.pos -> string -> T'.t S.repr =
+   fun _ _ report -> (T'.default, report)
 
   (** 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 _ _ _ report -> ((), report)
+  let function_ : S.pos -> T.function_ -> T'.t S.repr list -> T'.t S.repr =
+   fun _ _ _ report -> (T'.default, report)
 
   (** Unary operator like [-123] or [+'Text']*)
-  let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
-   fun _ _ _ report -> ((), report)
+  let uoperator : S.pos -> T.uoperator -> T'.t S.repr -> T'.t S.repr =
+   fun _ _ _ report -> (T'.default, report)
 
   (** Binary operator, for a comparaison, or an operation *)
-  let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
-   fun _ _ _ _ report -> ((), report)
+  let boperator :
+      S.pos -> T.boperator -> T'.t S.repr -> T'.t S.repr -> T'.t S.repr =
+   fun _ _ _ _ report -> (T'.default, report)
 end
diff --git a/lib/syntax/report.ml b/lib/syntax/report.ml
index 9ad24c3..9dae0f5 100644
--- a/lib/syntax/report.ml
+++ b/lib/syntax/report.ml
@@ -31,6 +31,9 @@ let pp_pos : Format.formatter -> pos -> unit =
 type t = { level : level; loc : pos; message : string }
 [@@deriving show { with_path = false }]
 
+let debug : pos -> string -> t =
+ fun loc message -> { level = Debug; loc; message }
+
 let warn : pos -> string -> t =
  fun loc message -> { level = Warn; loc; message }
 
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index fb6135f..85e130d 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -93,7 +93,7 @@ module Instruction :
       S.pos ->
       (expression, t) S.clause ->
       elifs:(expression, t) S.clause list ->
-      else_:t S.repr list ->
+      else_:(S.pos * t S.repr list) option ->
       t S.repr =
    fun pos predicate ~elifs ~else_ report ->
     let clause (pos, expr, repr) =
@@ -101,7 +101,12 @@ module Instruction :
       (pos, fst @@ expr [], repr)
     in
     let elifs = List.map ~f:clause elifs
-    and else_ = List.map ~f:(fun instr -> fst @@ instr []) else_ in
+    and else_ =
+      match else_ with
+      | None -> []
+      | Some (_, instructions) ->
+          List.map ~f:(fun instr -> fst @@ instr []) instructions
+    in
 
     (Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }, report)
 
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index 0b62e95..b0d14ec 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -328,14 +328,18 @@ module Instruction = struct
       S.pos ->
       (expression, t) S.clause ->
       elifs:(expression, t) S.clause list ->
-      else_:t S.repr list ->
+      else_:(S.pos * t S.repr list) option ->
       t S.repr =
    fun _pos clause ~elifs ~else_ report ->
     (* Traverse the whole block recursively *)
     let report = fold_clause ((), report) clause in
     let report = List.fold_left elifs ~f:fold_clause ~init:report in
-    List.fold_left else_ ~init:report ~f:(fun ((), report) instruction ->
-        instruction report)
+
+    match else_ with
+    | None -> report
+    | Some (_, instructions) ->
+        List.fold_left instructions ~init:report
+          ~f:(fun ((), report) instruction -> instruction report)
 
   let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
    fun _pos ~label instructions report ->
diff --git a/test/dead_end.ml b/test/dead_end.ml
new file mode 100644
index 0000000..9cce62d
--- /dev/null
+++ b/test/dead_end.ml
@@ -0,0 +1,136 @@
+module Dead_end = Qsp_syntax.Dead_end
+module S = Qsp_syntax.S
+
+let _position = (Lexing.dummy_pos, Lexing.dummy_pos)
+let pp_pos = Qsp_syntax.Report.pp_pos
+
+type pos = S.pos
+
+let equal_pos : pos -> pos -> bool = fun _ _ -> true
+
+type t = Qsp_syntax.Report.t = {
+  level : Qsp_syntax.Report.level;
+  loc : pos;
+  message : string;
+}
+[@@deriving show, eq]
+
+let report : Qsp_syntax.Report.t list Alcotest.testable =
+  Alcotest.list @@ Alcotest.testable Qsp_syntax.Report.pp equal
+
+let parse :
+    string ->
+    (Dead_end.Location.t * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result
+    =
+ fun content ->
+  let lexing =
+    Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf
+  in
+  Qparser.Analyzer.parse (module Dead_end) lexing
+
+let get_report :
+    (Dead_end.Location.t * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result ->
+    Qsp_syntax.Report.t list = function
+  | Ok (_, report) -> report
+  | Error _ -> failwith "Error"
+
+let _test_instruction : string -> Qsp_syntax.Report.t list -> unit =
+ fun literal expected ->
+  let _location = Printf.sprintf {|# Location
+%s
+------- |} literal in
+  let actual = get_report @@ parse _location and msg = literal in
+
+  Alcotest.(check' report ~msg ~expected ~actual)
+
+(** This one is OK because act provide a solution in any case *)
+let ok () =
+  _test_instruction {|
+if 0:
+	act '': gt ''
+	if 1:
+		act '': gt ''
+	end
+end
+  |}
+    []
+
+(** Ignore top level dead end*)
+let toplevel () =
+  _test_instruction {|
+act 1:
+  act '': gt ''
+end
+
+if 1: act '': gt ''
+
+  |} []
+
+let else_branch () =
+  _test_instruction
+    {|
+if 0:
+	if 1:
+		act '': gt ''
+	else
+		act '': ''
+	end
+end
+  |}
+    [
+      {
+        level = Warn;
+        loc = _position;
+        message = "Possible dead end (unmatched path)";
+      };
+    ]
+
+let elseif_branch () =
+  _test_instruction
+    {|
+if 0:
+	if 1:
+		act '': ''
+    elseif 0:
+		act '': gt ''
+	end
+end
+  |}
+    [
+      {
+        level = Debug;
+        loc = _position;
+        message = "Possible dead end (no else fallback)";
+      };
+    ]
+
+let missing_else () =
+  _test_instruction {|
+if 0:
+	if 1: act '': gt ''
+end
+  |}
+    [
+      {
+        level = Debug;
+        loc = _position;
+        message = "Possible dead end (no else fallback)";
+      };
+    ]
+
+let nothing () = _test_instruction {|
+if 0:
+	if 1: 0
+end
+  |} []
+
+let test =
+  ( "Dead end",
+    [
+      Alcotest.test_case "No dead_end" `Quick ok;
+      Alcotest.test_case "top level" `Quick toplevel;
+      Alcotest.test_case "Else branch" `Quick else_branch;
+      Alcotest.test_case "ElseIf branch" `Quick elseif_branch;
+      Alcotest.test_case "Missing else" `Quick missing_else;
+      Alcotest.test_case "nothing" `Quick nothing;
+    ] )
diff --git a/test/qsp_parser_test.ml b/test/qsp_parser_test.ml
index cbbe91e..8629175 100644
--- a/test/qsp_parser_test.ml
+++ b/test/qsp_parser_test.ml
@@ -1 +1,2 @@
-let () = Alcotest.run "qsp_parser" [ Syntax.test; Syntax_error.test ]
+let () =
+  Alcotest.run "qsp_parser" [ Syntax.test; Syntax_error.test; Dead_end.test ]