bin/qsp_parser.ml

@@ -12,7 +12,7 @@ let filter_report : Args.filters -> Report.t list -> Report.t -> Report.t list =
 
   match is_ok with true -> r :: reports | _ -> reports
 
-type ctx = { error_nb : int; warn_nb : int; debug_nb : int }
+type ctx = { error_nb : int; warn_nb : int; debug_nb : int; fatal_error : bool }
 
 (*
     List all the controls to apply 
@@ -22,6 +22,7 @@ let available_checks =
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Type_of);
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Dead_end);
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Nested_strings);
+    snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Locations);
   ]
 
 let pp_module formatter (module A : Qsp_syntax.S.Analyzer) =
@@ -83,39 +84,44 @@ let checkers : (module Qsp_syntax.S.Analyzer) Lazy.t =
     (module Check))
 
 (** Read the source file until getting a report (the whole location has been
-    read properly), or until the first syntax error. 
-    *)
-let parse_location : ctx:ctx -> Qparser.Lexbuf.t -> Args.filters -> ctx =
- fun ~ctx lexbuf filters ->
-  let (module Check) = Lazy.force checkers in
+    read properly), or until the first syntax error.
+
+    The function update the context (list of errors) passed in arguments. *)
+let parse_location :
+    type context.
+    ctx:ctx ref ->
+    (module Qsp_syntax.S.Analyzer with type context = context) ->
+    context ->
+    Qparser.Lexbuf.t ->
+    Args.filters ->
+    unit =
+ fun ~ctx (module Check) context lexbuf filters ->
   let result =
-    Qparser.Analyzer.parse (module Check) lexbuf
-    |> Result.map (fun (_, f) ->
-           List.fold_left f ~init:[] ~f:(filter_report filters)
+    Qparser.Analyzer.parse (module Check) lexbuf context
+    |> Result.map (fun f ->
+           List.fold_left f.Qparser.Analyzer.report ~init:[]
+             ~f:(filter_report filters)
            |> List.sort ~cmp:Report.compare)
   in
   match result with
-  | Ok report -> (
+  | Ok [] -> ()
+  | Ok report ->
       (* Display the result *)
-      match report with
-      | [] -> ctx
-      | _ ->
-          let start_position, _ = Qparser.Lexbuf.positions lexbuf in
-          Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@."
-            start_position.Lexing.pos_fname Report.pp_result report;
-
-          List.fold_left report ~init:ctx ~f:(fun ctx report ->
-              match report.Report.level with
-              | Error -> { ctx with error_nb = succ ctx.error_nb }
-              | Warn -> { ctx with warn_nb = succ ctx.warn_nb }
-              | Debug -> { ctx with debug_nb = succ ctx.debug_nb }))
+      let start_position, _ = Qparser.Lexbuf.positions lexbuf in
+      Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@."
+        start_position.Lexing.pos_fname Report.pp_result report;
+
+      List.iter report ~f:(fun report ->
+          match report.Report.level with
+          | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb }
+          | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb }
+          | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb })
   | Error e ->
+      (* Syntax error, we haven’t been able to run the test *)
       let start_position, _ = Qparser.Lexbuf.positions lexbuf in
       Format.fprintf Format.std_formatter "Location@ %s@;@[%a]@."
         start_position.Lexing.pos_fname Report.pp e;
-      { ctx with error_nb = succ ctx.error_nb }
-
-let default_ctx = { error_nb = 0; warn_nb = 0; debug_nb = 0 }
+      ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true }
 
 let () =
   let file_names, parameters =
@@ -129,6 +135,12 @@ let () =
   let lexer, parameters =
     match Filename.extension file_name with
     | ".qsrc" ->
+        (* Deactivate the tests which only applies to a global file *)
+        List.iter available_checks ~f:(fun t ->
+            let (module C : Qsp_syntax.S.Analyzer) =
+              Qsp_syntax.Check.get_module t
+            in
+            if C.is_global then C.active := false);
         (* The source file are in UTF-8, and we can use the file line number as
            we have only a single location. *)
         ( Sedlexing.Utf8.from_channel ic,
@@ -142,15 +154,40 @@ let () =
     Qparser.Lexbuf.from_lexbuf ~reset_line:parameters.reset_line lexer
   in
 
-  let ctx = ref default_ctx in
+  (* Initialize all the checkers before parsing the source *)
+  let (module Check) = Lazy.force checkers in
+  let check_context = Check.initialize () in
+  let ctx =
+    ref { error_nb = 0; warn_nb = 0; debug_nb = 0; fatal_error = false }
+  in
+
   let () =
     try
       while true do
-        ctx := parse_location ~ctx:!ctx lexer parameters.filters
+        parse_location ~ctx
+          (module Check)
+          check_context lexer parameters.filters
       done
     with Qparser.Lexer.EOF -> ()
   in
 
+  (match !ctx.fatal_error with
+  | true ->
+      Format.fprintf Format.std_formatter
+        "(Ignoring global checkers because of the previous syntax errors)@."
+  | false ->
+      (* If the parsing was global and we didn’t got parsing error, extract the
+         result for the whole test *)
+      let global_report = Check.finalize check_context in
+      List.iter global_report ~f:(fun (f_name, report) ->
+          Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@." f_name
+            Report.pp report;
+
+          match report.Report.level with
+          | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb }
+          | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb }
+          | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb }));
+
   match (!ctx.error_nb, !ctx.warn_nb) with
   | 0, 0 -> (
       print_endline "No errors found";

lib/qparser/analyzer.ml

@@ -1,22 +1,30 @@
+type 'a result = { content : 'a; report : Qsp_syntax.Report.t list }
+
 (** 
     Run the QSP parser and apply the analyzer over it.
 
     See [syntax/S]
  *)
-let parse :
-    type a.
-    (module Qsp_syntax.S.Analyzer with type Location.t = a) ->
+let rec parse :
+    type a context.
+    (module Qsp_syntax.S.Analyzer
+       with type Location.t = a
+        and type context = context) ->
     Lexbuf.t ->
-    (a * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) Result.t =
- fun (module S : Qsp_syntax.S.Analyzer with type Location.t = a) ->
+    context ->
+    (a result, Qsp_syntax.Report.t) Result.t =
+ fun (module S : Qsp_syntax.S.Analyzer
+       with type Location.t = a
+        and type context = context) ->
   let module Parser = Parser.Make (S) in
   let module IncrementalParser =
     Interpreter.Interpreter (Parser.MenhirInterpreter) in
-  fun l ->
+  fun l context ->
     let lexer = Lexbuf.tokenize Lexer.main l in
 
     let init = Parser.Incremental.main (fst (Lexbuf.positions l)) in
 
+    (* Firslty, check if we are able to read the whole syntax from the source *)
     let evaluation =
       try IncrementalParser.of_lexbuf lexer l init with
       | Lexer.LexError message ->
@@ -35,30 +43,53 @@ let parse :
           Error err
     in
 
-    evaluation
-    |> Result.map (fun r -> (r, S.Location.v r))
-    |> Result.map_error (fun e ->
-           let message =
-             match e.IncrementalParser.code with
-             | Interpreter.InvalidSyntax -> "Invalid Syntax"
-             | Interpreter.UnrecoverableError -> "UnrecoverableError"
-             | Interpreter.Custom msg -> msg
-             | Interpreter.MenhirCode c ->
-                 let message_content =
-                   try Parser_messages.message c
-                   with Not_found ->
-                     String.concat "" [ "(Error code "; string_of_int c; ")" ]
-                 in
+    (* Then evaluate the result *)
+    match (evaluation, Lexbuf.is_recovery l) with
+    | Ok r, _ ->
+        (* We have been able to read the syntax, apply the checkers over the
+           Tree *)
+        let content = r context in
+        Ok { content; report = S.Location.v content }
+    | _, true ->
+        (* This pattern can occur after recovering from an error. The
+           application attempt to start from a clean state in the next
+           location, but may fail to detect the correct position. If so, we
+           just start again until we hook the next location *)
+        parse (module S) l context
+    | Error e, _ ->
+        let message =
+          match e.IncrementalParser.code with
+          | Interpreter.UnrecoverableError -> "UnrecoverableError"
+          | Interpreter.InvalidSyntax -> "Invalid Syntax"
+          | Interpreter.Custom msg -> msg
+          | Interpreter.MenhirCode c ->
+              let message_content =
+                try Parser_messages.message c
+                with Not_found ->
+                  String.concat "" [ "(Error code "; string_of_int c; ")" ]
+              in
+              String.concat "" [ String.trim message_content ]
+        in
+
+        let report = Qsp_syntax.Report.error (e.start_pos, e.end_pos) message in
+        (* Rollback the buffer from the latest errror before discarding until
+           the end of the location. This ensure we will read the marker
+           for the end location in the case the error was actually in
+           this line itsef.
+
+           Example :
+
+            # location
+            <ERROR HERE>
 
-                 String.concat "" [ String.trim @@ message_content ]
-           in
-           let report =
-             Qsp_syntax.Report.error (e.start_pos, e.end_pos) message
-           in
+            ! ------- a
+            --- location ---------------------------------
+        *)
+        Lexbuf.rollback l;
 
-           (* Discard the remaining file to read. The parser is now in a blank
-              state, it does not make sense to keep feeding it with the new
-              tokens. *)
-           let () = try Lexer.discard l with _ -> () in
+        (* Discard the remaining file to read. The parser is now in a blank
+           state, it does not make sense to keep feeding it with the new
+           tokens. *)
+        let () = try Lexer.discard l with _ -> () in
 
-           report)
+        Error report

lib/qparser/analyzer.mli

@@ -1,7 +1,12 @@
+type 'a result = { content : 'a; report : Qsp_syntax.Report.t list }
+
 val parse :
-  (module Qsp_syntax.S.Analyzer with type Location.t = 'a) ->
+  (module Qsp_syntax.S.Analyzer
+     with type Location.t = 'a
+      and type context = 'context) ->
   Lexbuf.t ->
-  ('a * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) Result.t
+  'context ->
+  ('a result, Qsp_syntax.Report.t) Result.t
 (** Read the source and build a analyzis over it. 
 
 This method make the link between the source file and how to read it

lib/qparser/expression_parser.messages

@@ -36,6 +36,10 @@ main: LOCATION_START EOL IF IDENT COLUMN EOL ELSE EOL LOCATION_END
 A block starting with `IF` is not closed by `END`
 If there are nested blocks, the error will points the highest block.
 
+main: LOCATION_START EOL ACT IDENT COLUMN EOL IDENT AMPERSAND LOCATION_END
+
+    A block starting with `ACT` is not closed by `END`
+
 main: LOCATION_START EOL IDENT AMPERSAND END
 
 Unexpected `END`.
@@ -107,3 +111,4 @@ main: LOCATION_START EOL ACT IDENT COLUMN EOL END TEXT_MARKER
 main: LOCATION_START EOL FUNCTION L_PAREN IDENT COMA IDENT EOL
 
     Unclosed `(`
+

lib/qparser/lexbuf.ml

@@ -5,6 +5,7 @@ type t = {
   mutable start_p : Lexing.position option;
   state : state Stack.t;
   reset_line : bool;
+  mutable recovering : bool;
 }
 
 and lexer = t -> Tokens.token
@@ -50,7 +51,8 @@ let start : t -> unit =
       Sedlexing.set_position t.buffer { end_pos with Lexing.pos_lnum = 1 }
   in
   Stack.clear t.state;
-  t.start_p <- None
+  t.start_p <- None;
+  t.recovering <- false
 
 let positions : t -> Lexing.position * Lexing.position =
  fun t ->
@@ -62,7 +64,13 @@ let content : t -> string = fun t -> Sedlexing.Utf8.lexeme t.buffer
 
 let from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t =
  fun ?(reset_line = true) t ->
-  { buffer = t; start_p = None; reset_line; state = Stack.create () }
+  {
+    buffer = t;
+    start_p = None;
+    reset_line;
+    state = Stack.create ();
+    recovering = false;
+  }
 
 let set_start_position : t -> Lexing.position -> unit =
  fun t position ->
@@ -97,3 +105,6 @@ let overlay : t -> lexer -> lexer =
       match layer with
       | String wraper | EndString wraper -> wraper.start_string acc
       | _ -> acc)
+
+let start_recovery : t -> unit = fun t -> t.recovering <- true
+let is_recovery : t -> bool = fun t -> t.recovering

lib/qparser/lexbuf.mli

@@ -7,7 +7,7 @@ val from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t
 (** Create a new buffer *)
 
 val start : t -> unit
-(** Intialize a new run *)
+(** Intialize a new run. *)
 
 val buffer : t -> Sedlexing.lexbuf
 (** Extract the sedlex buffer. Required in each rule. *)
@@ -82,3 +82,10 @@ val leave_state : t -> unit
 (** Leave the current state *)
 
 val overlay : t -> lexer -> lexer
+
+val start_recovery : t -> unit
+(** Set the lexer in recovery mode, the lexer raise this mode after an error,
+    in order to ignore the further errors until a new location *)
+
+val is_recovery : t -> bool
+(** Check if the lexer is in recovery mode *)

lib/qparser/lexer.ml

@@ -277,6 +277,7 @@ let main buffer =
       parser buffer
 
 let rec discard buffer =
+  let () = Lexbuf.start_recovery buffer in
   let lexbuf = Lexbuf.buffer buffer in
 
   match%sedlex lexbuf with
@@ -291,8 +292,5 @@ let rec discard buffer =
          (for example a missing quote). *)
       leave_expression buffer;
       ()
-  | '!' ->
-      ignore @@ skip_comment buffer;
-      discard buffer
   | any -> discard buffer
   | _ -> raise EOF

lib/qparser/parser.mly

@@ -9,7 +9,7 @@
         ; body : Analyzer.Instruction.t list
         ; pos : Qsp_syntax.S.pos
         ; clauses : (
-            ( (Analyzer.Instruction.expression, Analyzer.Instruction.t) Qsp_syntax.S.clause list 
+            ( (Analyzer.Expression.t', Analyzer.Instruction.t) Qsp_syntax.S.clause list 
             * (Qsp_syntax.S.pos * Analyzer.Instruction.t list) option
             ) option )
         }
@@ -18,7 +18,7 @@
 %}
 
 %parameter<Analyzer: Qsp_syntax.S.Analyzer>
-%start <(Analyzer.Location.t)>main
+%start <(Analyzer.context -> Analyzer.Location.t)>main
 %on_error_reduce expression instruction unary_operator assignation_operator
 
 %% 
@@ -31,7 +31,7 @@ main:
       LOCATION_END
     { 
         let instructions = List.map instructions ~f:(Analyzer.Instruction.v) in
-        Analyzer.Location.location $loc instructions
+        fun context -> Analyzer.Location.location context $loc instructions
     }
 
 before_location:

lib/syntax/S.ml

@@ -95,9 +95,10 @@ end
 module type Location = sig
   type t
   type instruction
+  type context
 
   val v : t -> Report.t list
-  val location : pos -> instruction list -> t
+  val location : context -> pos -> instruction list -> t
 end
 
 (** {1 Unified module used by the parser } *)
@@ -112,9 +113,27 @@ module type Analyzer = sig
   val active : bool ref
   (** Is the test active or not *)
 
+  val is_global : bool
+  (** Declare the checker as global. It requires to run over the whole file and
+      will be disabled if the application only check a single location. 
+
+      Also, the test will be disabled if a syntax error is reported during the
+      parsing, because this tell that I haven’t been able to analyse the whole
+      source code. *)
+
+  type context
+  (** Context used to keep information during the whole test *)
+
+  val initialize : unit -> context
+  (** Initialize the context before starting to parse the content *)
+
   module Expression : Expression
-  module Instruction : Instruction with type expression = Expression.t'
-  module Location : Location with type instruction = Instruction.t'
+  module Instruction : Instruction with type expression := Expression.t'
+
+  module Location :
+    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

lib/syntax/check.ml

@@ -55,12 +55,14 @@ type t =
             and type Expression.t' = 'b
             and type Instruction.t = 'c
             and type Instruction.t' = 'd
-            and type Location.t = 'e);
+            and type Location.t = 'e
+            and type context = 'f);
       expr_witness : 'a Id.typeid;
       expr' : 'b Id.typeid;
       instr_witness : 'c Id.typeid;
       instr' : 'd Id.typeid;
       location_witness : 'e Id.typeid;
+      context : 'f Id.typeid;
     }
       -> t
 
@@ -70,16 +72,27 @@ let build :
         and type Expression.t' = _
         and type Instruction.t = _
         and type Instruction.t' = _
-        and type Location.t = 'a) ->
+        and type Location.t = 'a
+        and type context = _) ->
     '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
+  and location_witness = Id.newtype ()
+  and context = Id.newtype () in
   let t =
-    E { module_; expr_witness; expr'; instr_witness; instr'; location_witness }
+    E
+      {
+        module_;
+        expr_witness;
+        expr';
+        instr_witness;
+        instr';
+        location_witness;
+        context;
+      }
   in
   (location_witness, t)
 
@@ -110,8 +123,32 @@ 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
+  (** We associate each context from the differents test in an array. The
+      context for this module is a sort of context of contexts *)
+
+  (** Initialize each test, and keep the result in the context. *)
+  let initialize : unit -> context =
+   fun () ->
+    Array.map A.t ~f:(fun (E { module_ = (module S); context; _ }) ->
+        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
 
@@ -127,9 +164,7 @@ module Make (A : App) = struct
             List.map values
               ~f:
                 (T.map_litteral ~f:(fun expr ->
-                     match get expr_witness (Array.get expr i) with
-                     | None -> failwith "Does not match"
-                     | Some value -> value))
+                     Option.get (get expr_witness (Array.get expr i))))
           in
           let value = S.Expression.literal pos values' in
           R { value; witness = expr_witness })
@@ -305,9 +340,7 @@ module Make (A : App) = struct
           let index_i =
             Option.map
               (fun expression ->
-                match get expr' (Array.get expression i) with
-                | None -> failwith "Does not match"
-                | Some value -> value)
+                Option.get (get expr' (Array.get expression i)))
               index
           in
           let variable = S.{ pos = var_pos; name; index = index_i } in
@@ -385,23 +418,31 @@ module Make (A : App) = struct
   end
 
   module Location :
-    S.Location with type t = result array and type instruction = Instruction.t' =
-  struct
+    S.Location
+      with type t = result array
+       and type instruction = Instruction.t'
+       and type context := context = struct
     type instruction = Instruction.t'
     type t = result array
 
-    let location : S.pos -> instruction list -> t =
-     fun pos args ->
+    let location : context -> S.pos -> instruction list -> t =
+     fun local_context pos args ->
       ignore pos;
 
       let result =
         Array.init len ~f:(fun i ->
-            let (E { module_ = (module A); instr'; location_witness; _ }) =
+            let (E
+                  { module_ = (module A); instr'; location_witness; context; _ })
+                =
               Array.get A.t i
             in
 
+            let local_context =
+              Option.get (get context (Array.get local_context i))
+            in
+
             let instructions = List.rev (Helper.expr_i args instr' i).values in
-            let value = A.Location.location pos instructions in
+            let value = A.Location.location local_context pos instructions in
             R { value; witness = location_witness })
       in
       result

lib/syntax/check.mli

@@ -28,7 +28,8 @@ val build :
       and type Expression.t' = _
       and type Instruction.t = _
       and type Instruction.t' = _
-      and type Location.t = 'a) ->
+      and type Location.t = 'a
+      and type context = _) ->
   'a Id.typeid * t
 (** Build a new check from a module following S.Analyzer signature. 
 

lib/syntax/dead_end.ml

@@ -2,11 +2,16 @@ 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
-  type t' = unit
 
   include Default.Expression (struct
     type nonrec t = t
@@ -18,7 +23,6 @@ module Expression = struct
 end
 
 module Instruction = struct
-  type expression = Expression.t'
   type cause = Missing_else | Unchecked_path
 
   type state = {
@@ -48,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
@@ -64,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 =
@@ -80,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_ ->
@@ -129,28 +133,27 @@ 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 : S.pos -> instruction list -> t =
-   fun _pos instructions ->
+  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) ->

lib/syntax/default.ml

@@ -17,6 +17,8 @@ module Expression (T' : T) = struct
       If missing, the index should be considered as [0].
    *)
 
+  type t' = T'.t
+
   let ident : (S.pos, T'.t) S.variable -> T'.t = fun _ -> T'.default
 
   (*

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

lib/syntax/nested_strings.ml

@@ -2,8 +2,14 @@ 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)
 
 module Expression = TypeBuilder.Make (struct
@@ -143,8 +149,8 @@ module Location = struct
 
   let v = Fun.id
 
-  let location : S.pos -> instruction list -> t =
-   fun pos intructions ->
+  let location : unit -> S.pos -> instruction list -> t =
+   fun () pos intructions ->
     ignore pos;
     List.concat intructions
 end

lib/syntax/tree.ml

@@ -2,8 +2,14 @@ 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
   [@@deriving eq, show]
@@ -68,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_ ->
@@ -101,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*)
@@ -116,9 +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 : S.pos -> instruction list -> t = fun pos block -> (pos, block)
+
+  let location : unit -> S.pos -> Instruction.t' list -> t =
+   fun () pos block -> (pos, block)
 end

lib/syntax/tree.mli

@@ -48,3 +48,4 @@ include
     with type Expression.t' = S.pos Ast.expression
      and type Instruction.t' = S.pos Ast.statement
      and type Location.t = S.pos * S.pos Ast.statement list
+     and type context = unit

lib/syntax/type_of.ml

@@ -2,8 +2,14 @@ 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 }
 
@@ -474,8 +480,8 @@ module Location = struct
 
   let v = Fun.id
 
-  let location : S.pos -> instruction list -> t =
-   fun _pos instructions ->
+  let location : unit -> S.pos -> instruction list -> t =
+   fun () _pos instructions ->
     let report =
       List.fold_left instructions ~init:[] ~f:(fun report instruction ->
           let report' = instruction in

test/location.ml

@@ -0,0 +1,28 @@
+module Check = Make_checkTest.M (Qsp_syntax.Locations)
+
+let _position = (Lexing.dummy_pos, Lexing.dummy_pos)
+
+let error_message =
+  [
+    ( "Location",
+      Check.
+        {
+          level = Error;
+          loc = _position;
+          message = "The location unknown_place does not exists";
+        } );
+  ]
+
+let ok () = Check.global_check "gt 'location'" []
+let ok_upper () = Check.global_check "gt 'LOCATION'" []
+let missing_gt () = Check.global_check "gt 'unknown_place'" error_message
+let missing_gs () = Check.global_check "gs 'unknown_place'" error_message
+
+let test =
+  ( "Locations",
+    [
+      Alcotest.test_case "Ok" `Quick ok;
+      Alcotest.test_case "Ok upper" `Quick ok_upper;
+      Alcotest.test_case "Missing GT" `Quick missing_gt;
+      Alcotest.test_case "Missing GS" `Quick missing_gs;
+    ] )

test/make_checkTest.ml

@@ -15,26 +15,32 @@ module M (Check : Qsp_syntax.S.Analyzer) = struct
   }
   [@@deriving show, eq]
 
-  let report : Qsp_syntax.Report.t list Alcotest.testable =
+  let report : t list Alcotest.testable =
     Alcotest.list @@ Alcotest.testable Qsp_syntax.Report.pp equal
 
+  let report_global : (string * t) list Alcotest.testable =
+    Alcotest.list
+    @@ Alcotest.pair Alcotest.string
+         (Alcotest.testable Qsp_syntax.Report.pp equal)
+
   let parse :
+      ?context:Check.context ->
       string ->
-      (Check.Location.t * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result
-      =
-   fun content ->
+      (Check.Location.t Qparser.Analyzer.result, t) result =
+   fun ?context content ->
     let lexing =
       Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf
     in
-    Qparser.Analyzer.parse (module Check) lexing
+    let context = Option.value context ~default:(Check.initialize ()) in
+    Qparser.Analyzer.parse (module Check) lexing context
 
   let get_report :
-      (Check.Location.t * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result ->
+      (Check.Location.t Qparser.Analyzer.result, Qsp_syntax.Report.t) result ->
       Qsp_syntax.Report.t list = function
-    | Ok (_, report) -> report
+    | Ok v -> v.report
     | Error _ -> failwith "Error"
 
-  let _test_instruction : string -> Qsp_syntax.Report.t list -> unit =
+  let _test_instruction : string -> t list -> unit =
    fun literal expected ->
     let _location = Printf.sprintf {|# Location
 %s
@@ -42,4 +48,22 @@ module M (Check : Qsp_syntax.S.Analyzer) = struct
     let actual = get_report @@ parse _location and msg = literal in
 
     Alcotest.(check' report ~msg ~expected ~actual)
+
+  (** Run a test over the whole file. 
+      The parsing of the content shall not report any error.
+   *)
+  let global_check : string -> (string * t) list -> unit =
+   fun literal expected ->
+    let _location = Printf.sprintf {|# Location
+%s
+------- |} literal in
+    let context = Check.initialize () in
+    let actual = get_report @@ parse ~context _location in
+    let () =
+      Alcotest.(
+        check' report ~msg:"Error reported during parsing" ~expected:[] ~actual)
+    in
+    let msg = literal in
+    let actual = Check.finalize context in
+    Alcotest.(check' report_global ~msg ~expected ~actual)
 end

test/qsp_parser_test.ml

@@ -7,4 +7,5 @@ let () =
       Type_of.test;
       Dead_end.test;
       Nested_string.test;
+      Location.test;
     ]

test/syntax.ml

@@ -27,11 +27,13 @@ let parse : string -> (S.pos location, Qsp_syntax.Report.t) result =
   let lexing =
     Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf
   in
-  Qparser.Analyzer.parse (module Parser) lexing
-  |> Result.map (fun (location, _report) ->
+  let context = Parser.initialize () in
+  Qparser.Analyzer.parse (module Parser) lexing context
+  |> Result.map (fun v ->
          (* Uncatched excteptions here, but we are in the tests…
             If it’s fail here I have an error in the code. *)
-         Array.get location 0 |> Check.get location_id |> Option.get)
+         Array.get v.Qparser.Analyzer.content 0
+         |> Check.get location_id |> Option.get)
 
 let location : S.pos location Alcotest.testable =
   let equal = equal_location (fun _ _ -> true) in

test/syntax_error.ml

@@ -234,6 +234,20 @@ iif(1,0,0 + iif(1, 1, 2)
 |}
     { level = Error; loc = _position; message = "Unclosed `(`" }
 
+let unclosed_act () =
+  _test_instruction {|
+		act 'Smthg':
+			else
+			end
+		end|}
+    {
+      level = Error;
+      loc = _position;
+      message =
+        "A block starting with `ACT` is not closed by `END`\n\
+         If there are nested blocks, the error will points the highest block.";
+    }
+
 let test =
   ( "Syntax Errors",
     [
@@ -253,4 +267,5 @@ let test =
       Alcotest.test_case "Location change" `Quick location_change;
       Alcotest.test_case "Misplaced if" `Quick misplaced_if;
       Alcotest.test_case "(()" `Quick unclosed_paren2;
+      Alcotest.test_case "act: else" `Quick unclosed_act;
     ] )