Moved the checks in a dedicated library

1 files changed, 174 insertions, 0 deletions

diff --git a/lib/checks/dead_end.ml b/lib/checks/dead_end.ml
new file mode 100644
index 0000000..629a966
--- /dev/null
+++ b/lib/checks/dead_end.ml
@@ -0,0 +1,174 @@
+open StdLabels
+module S = Qsp_syntax.S
+module T = Qsp_syntax.T
+module Report = Qsp_syntax.Report
+
+let identifier = "dead_end"
+let description = "Check for dead end in the code"
+let is_global = false
+let active = ref false
+
+type context = unit
+
+let initialize = Fun.id
+let finalize () = []
+
+module Expression = struct
+  type t = unit
+
+  include Default.Expression (struct
+    type nonrec t = t
+
+    let default = ()
+  end)
+
+  let v : t -> t' = fun () -> ()
+end
+
+module Instruction = struct
+  type cause = Missing_else | Unchecked_path
+
+  type state = {
+    block_pos : S.pos;
+    has_gt : bool;
+    is_gt : bool;
+    pos : (cause * S.pos) option;
+  }
+
+  type t = state
+  type t' = state
+
+  (** For each instruction, return thoses two informations :
+
+      - the intruction contains at [gt] 
+      - the last instruction is a [gt]
+
+    *)
+  let v : t -> t' = fun t -> t
+
+  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 : S.pos -> T.keywords -> Expression.t' list -> t =
+   fun pos f _ ->
+    ignore pos;
+    match f with
+    | T.Goto | T.XGoto ->
+        { block_pos = pos; has_gt = true; is_gt = true; pos = None }
+    | T.Gosub -> { block_pos = pos; has_gt = false; is_gt = true; pos = None }
+    | _ -> default
+
+  (** Label for a loop *)
+  let location : S.pos -> string -> t = fun _ _ -> default
+
+  (** Comment *)
+  let comment : S.pos -> t = fun _ -> default
+
+  (** Raw expression *)
+  let expression : Expression.t' -> t = fun _ -> default
+
+  (** The content of a block is very linear, I only need to check the last element *)
+  let check_block : S.pos -> t list -> t =
+   fun pos instructions ->
+    let last_element =
+      List.fold_left instructions ~init:default ~f:(fun t instruction ->
+          let result = instruction 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 })
+    in
+    last_element
+
+  let if_ :
+      S.pos ->
+      (Expression.t', t) S.clause ->
+      elifs:(Expression.t', t) S.clause list ->
+      else_:(S.pos * t list) option ->
+      t =
+   fun pos clause ~elifs ~else_ ->
+    (* For each block, evaluate the instructions *)
+    let res, has_gt, is_gt =
+      List.fold_left ~init:([], false, false) (clause :: elifs)
+        ~f:(fun (acc, has_gt, is_gt) clause ->
+          let pos, _, instructions = clause in
+          let clause_t = check_block pos instructions in
+          let has_gt = has_gt || clause_t.has_gt
+          and is_gt = is_gt || clause_t.is_gt in
+
+          ((clause_t, pos) :: acc, has_gt, is_gt))
+    in
+
+    let else_pos, else_block =
+      match else_ with
+      | Some (pos, instructions) ->
+          let block = check_block pos instructions in
+          (pos, block)
+      | None -> (pos, default)
+    in
+    let has_gt = has_gt || else_block.has_gt
+    and is_gt = is_gt || else_block.is_gt in
+
+    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
+    | 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 }
+            | 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) })
+        | _, _ -> { default with block_pos = pos; has_gt; is_gt })
+
+  let act : S.pos -> label:Expression.t' -> t list -> t =
+   fun pos ~label expressions ->
+    ignore label;
+    check_block pos expressions
+
+  let assign :
+      S.pos ->
+      (S.pos, Expression.t') S.variable ->
+      T.assignation_operator ->
+      Expression.t' ->
+      t =
+   fun _ _ _ _ -> default
+end
+
+module Location = struct
+  type t = Report.t list
+
+  let v = Fun.id
+
+  let location : unit -> S.pos -> Instruction.t' list -> t =
+   fun () _pos instructions ->
+    List.fold_left instructions ~init:[] ~f:(fun report t ->
+        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