Added a new check to ensure that every call to another location points to an existing one

7 files changed, 205 insertions, 25 deletions

diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml
index 583249e..e691b38 100644
--- a/lib/syntax/S.ml
+++ b/lib/syntax/S.ml
@@ -113,6 +113,8 @@ module type Analyzer = sig
   val active : bool ref
   (** Is the test active or not *)
 
+  val is_global : bool
+
   type context
   (** Context used to keep information during the whole test *)
 
@@ -120,10 +122,12 @@ module type Analyzer = sig
   (** Initialize the context before starting to parse the content *)
 
   module Expression : Expression
-  module Instruction : Instruction with type expression = Expression.t'
+  module Instruction : Instruction with type expression := Expression.t'
 
   module Location :
-    Location with type instruction = Instruction.t' and type context := context
+    Location with type instruction := Instruction.t' and type context := context
+
+  val finalize : context -> (string * Report.t) list
 end
 
 (** Helper module used in order to convert elements from the differents
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
index a5db091..9292a7a 100644
--- a/lib/syntax/check.ml
+++ b/lib/syntax/check.ml
@@ -123,6 +123,7 @@ end
 module Make (A : App) = struct
   let identifier = "main_checker"
   let description = "Internal module"
+  let is_global = false
   let active = ref false
 
   type context = result Array.t
@@ -136,6 +137,18 @@ module Make (A : App) = struct
         let value = S.initialize () in
         R { value; witness = context })
 
+  let finalize : result Array.t -> (string * Report.t) list =
+   fun context_array ->
+    let _, report =
+      Array.fold_left A.t ~init:(0, [])
+        ~f:(fun (i, acc) (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
+          (i + 1, List.rev_append reports acc))
+    in
+    report
+
   (* Global variable for the whole module *)
   let len = Array.length A.t
 
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
index ddf7edb..c0dbc58 100644
--- a/lib/syntax/dead_end.ml
+++ b/lib/syntax/dead_end.ml
@@ -2,11 +2,13 @@ open StdLabels
 
 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
@@ -21,7 +23,6 @@ module Expression = struct
 end
 
 module Instruction = struct
-  type expression = Expression.t'
   type cause = Missing_else | Unchecked_path
 
   type state = {
@@ -51,7 +52,7 @@ module Instruction = struct
     }
 
   (** Call for an instruction like [GT] or [*CLR] *)
-  let call : S.pos -> T.keywords -> expression list -> t =
+  let call : S.pos -> T.keywords -> Expression.t' list -> t =
    fun pos f _ ->
     ignore pos;
     match f with
@@ -67,7 +68,7 @@ module Instruction = struct
   let comment : S.pos -> t = fun _ -> default
 
   (** Raw expression *)
-  let expression : expression -> t = fun _ -> default
+  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 =
@@ -83,8 +84,8 @@ module Instruction = struct
 
   let if_ :
       S.pos ->
-      (expression, t) S.clause ->
-      elifs:(expression, t) S.clause list ->
+      (Expression.t', t) S.clause ->
+      elifs:(Expression.t', t) S.clause list ->
       else_:(S.pos * t list) option ->
       t =
    fun pos clause ~elifs ~else_ ->
@@ -132,27 +133,26 @@ module Instruction = struct
                 { 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 list -> t =
+  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) S.variable ->
+      (S.pos, Expression.t') S.variable ->
       T.assignation_operator ->
-      expression ->
+      Expression.t' ->
       t =
    fun _ _ _ _ -> default
 end
 
 module Location = struct
   type t = Report.t list
-  type instruction = Instruction.t'
 
   let v = Fun.id
 
-  let location : unit -> S.pos -> instruction list -> t =
+  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
diff --git a/lib/syntax/locations.ml b/lib/syntax/locations.ml
new file mode 100644
index 0000000..17f33bd
--- /dev/null
+++ b/lib/syntax/locations.ml
@@ -0,0 +1,159 @@
+open StdLabels
+
+module IgnoreCaseString = struct
+  type t = string
+
+  let compare t1 t2 =
+    String.compare (String.lowercase_ascii t1) (String.lowercase_ascii t2)
+
+  let equal t1 t2 =
+    String.equal (String.lowercase_ascii t1) (String.lowercase_ascii t2)
+end
+
+module LocationSet = Set.Make (IgnoreCaseString)
+module LocationCalls = Map.Make (IgnoreCaseString)
+
+let identifier = "locations"
+let description = "Ensure every call points to an existing location"
+let is_global = true
+let active = ref true
+
+type t = {
+  locations : LocationSet.t;
+  calls : (string * S.pos) list LocationCalls.t;
+}
+
+type context = t ref
+
+let initialize () =
+  ref { locations = LocationSet.empty; calls = LocationCalls.empty }
+
+let finalize : context -> (string * Report.t) list =
+ fun context ->
+  LocationCalls.fold
+    (fun location positions acc ->
+      let message = Printf.sprintf "The location %s does not exists" location in
+
+      List.fold_left ~init:acc (List.rev positions)
+        ~f:(fun acc (loc, position) ->
+          let report = Report.error position message in
+          (loc, report) :: acc))
+    !context.calls []
+
+(** Register a new call to a defined location. *)
+let registerCall : S.pos -> string -> t -> t =
+ fun pos location t ->
+  let file_name = (fst pos).Lexing.pos_fname in
+  match
+    IgnoreCaseString.equal location file_name
+    || LocationSet.mem location t.locations
+  with
+  | true -> t
+  | false ->
+      (* The location is not yet defined, register the call for later *)
+      let calls =
+        LocationCalls.update location
+          (function
+            | None -> Some [ (file_name, pos) ]
+            | Some poss ->
+                Some
+                  (let new_pos = (file_name, pos) in
+                   new_pos :: poss))
+          t.calls
+      in
+      { t with calls }
+
+(** Add a new location in the list of all the collected elements *)
+let registerLocation : string -> t -> t =
+ fun location t ->
+  let calls = LocationCalls.remove location t.calls
+  and locations = LocationSet.add location t.locations in
+  { calls; locations }
+
+(** The module Expression is pretty simple, we are only interrested by the
+    strings ( because only the first argument of [gt …] is read ). 
+
+    If the string is too much complex, we just ignore it. *)
+module Expression = struct
+  type t = string option
+
+  include Default.Expression (struct
+    type nonrec t = t
+
+    let default = None
+  end)
+
+  let v : t -> t' = Fun.id
+
+  (* Extract the litteral if this is a simple text *)
+  let literal : S.pos -> t' T.literal list -> t' =
+   fun _ ll -> match ll with Text lit :: [] -> Some lit | _ -> None
+end
+
+module Instruction = struct
+  type nonrec t = t -> t
+  type t' = t
+
+  let v : t -> t' = Fun.id
+
+  (** Keep a track of every gt or gs instruction *)
+  let call : S.pos -> T.keywords -> Expression.t' list -> t =
+   fun pos fn args t ->
+    match (fn, args) with
+    | T.Goto, Some dest :: _ -> registerCall pos dest t
+    | T.Gosub, Some dest :: _ -> registerCall pos dest t
+    | _ -> t
+
+  let location : S.pos -> string -> t = fun _ _ -> Fun.id
+  let comment : S.pos -> t = fun _ -> Fun.id
+  let expression : Expression.t' -> t = fun _ -> Fun.id
+
+  let if_ :
+      S.pos ->
+      (Expression.t', t) S.clause ->
+      elifs:(Expression.t', t) S.clause list ->
+      else_:(S.pos * t list) option ->
+      t =
+   fun _ clause ~elifs ~else_ t ->
+    let traverse_clause t clause =
+      let _, _, block = clause in
+      List.fold_left block ~init:t ~f:(fun t instruction -> instruction t)
+    in
+
+    let t = traverse_clause t clause in
+    let t = List.fold_left ~init:t ~f:traverse_clause elifs in
+    match else_ with
+    | None -> t
+    | Some (_, instructions) ->
+        List.fold_left instructions ~init:t ~f:(fun t instruction ->
+            instruction t)
+
+  let act : S.pos -> label:Expression.t' -> t list -> t =
+   fun _ ~label instructions t ->
+    ignore label;
+    List.fold_left instructions ~init:t ~f:(fun t instruction -> instruction t)
+
+  let assign :
+      S.pos ->
+      (S.pos, Expression.t') S.variable ->
+      T.assignation_operator ->
+      Expression.t' ->
+      t =
+   fun _ _ _ _ -> Fun.id
+end
+
+module Location = struct
+  type t = unit
+
+  let v : t -> Report.t list = fun () -> []
+
+  let location : context -> S.pos -> Instruction.t list -> t =
+   fun context pos instructions ->
+    (* Register the location *)
+    let file_name = (fst pos).Lexing.pos_fname in
+    let c = registerLocation file_name !context in
+    (* Then update the list of all the calls to the differents locations *)
+    context :=
+      List.fold_left instructions ~init:c ~f:(fun t instruction ->
+          instruction t)
+end
diff --git a/lib/syntax/nested_strings.ml b/lib/syntax/nested_strings.ml
index 0119197..dee7af0 100644
--- a/lib/syntax/nested_strings.ml
+++ b/lib/syntax/nested_strings.ml
@@ -2,11 +2,13 @@ open StdLabels
 
 let identifier = "escaped_string"
 let description = "Check for unnecessary use of expression encoded in string"
+let is_global = false
 let active = ref true
 
 type context = unit
 
 let initialize = Fun.id
+let finalize () = []
 
 module TypeBuilder = Compose.Expression (Get_type)
 
diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml
index 6f6e7f2..b7d9d15 100644
--- a/lib/syntax/tree.ml
+++ b/lib/syntax/tree.ml
@@ -2,11 +2,13 @@ open StdLabels
 
 let identifier = "tree"
 let description = "Build the AST"
+let is_global = false
 let active = ref true
 
 type context = unit
 
 let initialize = Fun.id
+let finalize () = []
 
 module Ast = struct
   type 'a literal = 'a T.literal = Text of string | Expression of 'a
@@ -72,28 +74,27 @@ end
 
 module Instruction :
   S.Instruction
-    with type expression = Expression.t'
-     and type t' = S.pos Ast.statement = struct
+    with type t' = S.pos Ast.statement
+     and type expression = Expression.t' = struct
   type t = S.pos Ast.statement
   type t' = t
+  type expression = Expression.t'
 
   let v : t -> t' = fun t -> t
 
-  type expression = Expression.t'
-
-  let call : S.pos -> T.keywords -> expression list -> t =
+  let call : S.pos -> T.keywords -> Expression.t' list -> t =
    fun pos name args -> Ast.Call (pos, name, args)
 
   let location : S.pos -> string -> t =
    fun loc label -> Ast.Location (loc, label)
 
   let comment : S.pos -> t = fun pos -> Ast.Comment pos
-  let expression : expression -> t = fun expr -> Ast.Expression expr
+  let expression : Expression.t' -> t = fun expr -> Ast.Expression expr
 
   let if_ :
       S.pos ->
-      (expression, t) S.clause ->
-      elifs:(expression, t) S.clause list ->
+      (Expression.t', t) S.clause ->
+      elifs:(Expression.t', t) S.clause list ->
       else_:(S.pos * t list) option ->
       t =
    fun pos predicate ~elifs ~else_ ->
@@ -105,14 +106,14 @@ module Instruction :
 
     Ast.If { loc = pos; then_ = clause predicate; elifs; else_ }
 
-  let act : S.pos -> label:expression -> t list -> t =
+  let act : S.pos -> label:Expression.t' -> t list -> t =
    fun pos ~label statements -> Ast.Act { loc = pos; label; statements }
 
   let assign :
       S.pos ->
-      (S.pos, expression) S.variable ->
+      (S.pos, Expression.t') S.variable ->
       T.assignation_operator ->
-      expression ->
+      Expression.t' ->
       t =
    fun pos_loc { pos; name; index } op expr ->
     (*let index = Option.map (fun i -> fst @@ Expression.observe (i [])) index*)
@@ -120,11 +121,10 @@ module Instruction :
 end
 
 module Location = struct
-  type instruction = Instruction.t'
   type t = S.pos * S.pos Ast.statement list
 
   let v _ = []
 
-  let location : unit -> S.pos -> instruction list -> t =
+  let location : unit -> S.pos -> Instruction.t' list -> t =
    fun () pos block -> (pos, block)
 end
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index fcce565..410a0b1 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -2,11 +2,13 @@ open StdLabels
 
 let identifier = "type_check"
 let description = "Ensure all the expression are correctly typed"
+let is_global = false
 let active = ref true
 
 type context = unit
 
 let initialize = Fun.id
+let finalize () = []
 
 module Helper = struct
   type argument_repr = { pos : S.pos; t : Get_type.t }