aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bin/qsp_parser.ml18
-rw-r--r--lib/qparser/parser.mly2
-rw-r--r--lib/syntax/S.ml8
-rw-r--r--lib/syntax/check.ml13
-rw-r--r--lib/syntax/dead_end.ml20
-rw-r--r--lib/syntax/locations.ml159
-rw-r--r--lib/syntax/nested_strings.ml2
-rw-r--r--lib/syntax/tree.ml26
-rw-r--r--lib/syntax/type_of.ml2
9 files changed, 224 insertions, 26 deletions
diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml
index fef6aac..30c0ac0 100644
--- a/bin/qsp_parser.ml
+++ b/bin/qsp_parser.ml
@@ -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) =
@@ -133,6 +134,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,
@@ -161,6 +168,17 @@ let () =
with Qparser.Lexer.EOF -> ()
in
+ (* If the parsing was global, 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";
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index 9501884..5c83fc2 100644
--- a/lib/qparser/parser.mly
+++ b/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 )
}
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 }
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-18 10:49:46 +0000