bin/qsp_parser.ml

@@ -24,6 +24,7 @@ let available_checks =
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Nested_strings);
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Locations);
     snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Dup_test);
+    snd @@ Qsp_syntax.Check.build (module Qsp_syntax.Write_only);
   ]
 
 let pp_module formatter (module A : Qsp_syntax.S.Analyzer) =

lib/syntax/check.ml

@@ -1,51 +1,14 @@
-(** This module provide a way to create new Id dynamically in the runtime,
-    and some fonctions for comparing them. *)
-module Id : sig
-  type 'a typeid
-  (** The type created on-the-fly. *)
-
-  val newtype : unit -> 'a typeid
-  (** Create a new instance of a dynamic type *)
-
-  type ('a, 'b) eq = Eq : ('a, 'a) eq
-
-  val try_cast : 'a typeid -> 'b typeid -> ('a, 'b) eq option
-  (** Compare two types using the Eq pattern *)
-end = struct
-  type 'a witness = ..
-
-  module type Witness = sig
-    type t
-    type _ witness += Id : t witness
-  end
-
-  type 'a typeid = (module Witness with type t = 'a)
-  type ('a, 'b) eq = Eq : ('a, 'a) eq
-
-  let try_cast : type a b. a typeid -> b typeid -> (a, b) eq option =
-   fun x y ->
-    let module X : Witness with type t = a = (val x) in
-    let module Y : Witness with type t = b = (val y) in
-    match X.Id with Y.Id -> Some Eq | _ -> None
-
-  let newtype (type u) () =
-    (* The extensible type need to be extended in a module, it is not possible
-       to declare a type in a function. That’s why we need to pack a module
-       here *)
-    let module Witness = struct
-      type t = u
-      type _ witness += Id : t witness
-    end in
-    (module Witness : Witness with type t = u)
-end
+module Id = Type.Id
 
 (** The the Id module, wrap a value in an existencial type with a witness
     associate with. *)
-type result = R : { value : 'a; witness : 'a Id.typeid } -> result
+type result = R : { value : 'a; witness : 'a Id.t } -> result
 
-let get : type a. a Id.typeid -> result -> a option =
+let get : type a. a Id.t -> result -> a option =
  fun typeid (R { value; witness }) ->
-  match Id.try_cast typeid witness with Some Eq -> Some value | None -> None
+  match Id.provably_equal typeid witness with
+  | Some Type.Equal -> Some value
+  | None -> None
 
 type t =
   | E : {
@@ -57,12 +20,12 @@ type t =
             and type Instruction.t' = 'd
             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;
+      expr_witness : 'a Id.t;
+      expr' : 'b Id.t;
+      instr_witness : 'c Id.t;
+      instr' : 'd Id.t;
+      location_witness : 'e Id.t;
+      context : 'f Id.t;
     }
       -> t
 
@@ -74,14 +37,14 @@ let build :
         and type Instruction.t' = _
         and type Location.t = 'a
         and type context = _) ->
-    'a Id.typeid * t =
+    'a Id.t * 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 ()
-  and context = Id.newtype () in
+  let expr_witness = Id.make ()
+  and expr' = Id.make ()
+  and instr_witness = Id.make ()
+  and instr' = Id.make ()
+  and location_witness = Id.make ()
+  and context = Id.make () in
   let t =
     E
       {
@@ -106,9 +69,9 @@ end
 open StdLabels
 
 module Helper = struct
-  type 'a expr_list = { witness : 'a Id.typeid; values : 'a list }
+  type 'a expr_list = { witness : 'a Id.t; values : 'a list }
 
-  let expr_i : result array list -> 'a Id.typeid -> int -> 'a expr_list =
+  let expr_i : result array list -> 'a Id.t -> int -> 'a expr_list =
    fun args witness i ->
     let result =
       List.fold_left args ~init:{ values = []; witness }
@@ -355,8 +318,8 @@ module Make (A : App) = struct
     let rebuild_clause :
         type a b.
         int ->
-        a Id.typeid ->
-        b Id.typeid ->
+        a Id.t ->
+        b Id.t ->
         S.pos * result array * result array list ->
         (b, a) S.clause =
      fun i instr_witness expr' clause ->

lib/syntax/check.mli

@@ -15,7 +15,7 @@
 *)
 
 module Id : sig
-  type 'a typeid
+  type 'a t
   (** The type created on-the-fly. *)
 end
 
@@ -30,9 +30,9 @@ val build :
       and type Instruction.t' = _
       and type Location.t = 'a
       and type context = _) ->
-  'a Id.typeid * t
+  'a Id.t * t
 (** Build a new check from a module following S.Analyzer signature. 
-
+ypeid 
     Return the result type which hold the final result value, and checker
     itself. *)
 
@@ -40,7 +40,7 @@ val get_module : t -> (module S.Analyzer)
 
 type result
 
-val get : 'a Id.typeid -> result -> 'a option
+val get : 'a Id.t -> result -> 'a option
 (** The method [get] can be used to get the internal value for one of the
     checker used.
  *)

lib/syntax/write_only.ml

@@ -0,0 +1,217 @@
+(** Check all the write_only variables *)
+
+open StdLabels
+
+(** Identifier for the module *)
+let identifier = "write_only"
+
+(** Short description*)
+let description = "Check variables never read"
+
+(** Is the test active or not *)
+let active = ref false
+
+let is_global = true
+
+module Key = struct
+  type t = string
+
+  let equal = String.equal
+  let hash = Hashtbl.hash
+  let compare = String.compare
+end
+
+module StringMap = Hashtbl.Make (Key)
+module Set = Set.Make (Key)
+
+type data = { write : bool; read : bool; position : S.pos list }
+type context = (string * data) StringMap.t
+
+let initialize () = StringMap.create 16
+
+let keywords =
+  [
+    "BACKIMAGE";
+    "$BACKIMAGE";
+    "BCOLOR";
+    "DEBUG";
+    "DISABLESCROLL";
+    "DISABLESUBEX";
+    "FCOLOR";
+    "$FNAME";
+    "FSIZE";
+    "GC";
+    "LCOLOR";
+    "NOSAVE";
+  ]
+  |> Set.of_list
+
+let set_readed :
+    ?update_only:bool -> S.pos -> string -> string -> context -> unit =
+ fun ?(update_only = false) pos identifier filename map ->
+  if not (Set.mem identifier keywords) then
+    match (update_only, StringMap.find_opt map identifier) with
+    | false, None ->
+        StringMap.add map identifier
+          (filename, { write = false; read = true; position = [] })
+    | _, Some (filename, v) ->
+        StringMap.replace map identifier
+          (filename, { v with read = true; position = pos :: v.position })
+    | true, None -> ()
+
+let set_write : S.pos -> string -> string -> context -> unit =
+ fun pos identifier filename map ->
+  if not (Set.mem identifier keywords) then
+    match StringMap.find_opt map identifier with
+    | None ->
+        StringMap.add map identifier
+          (filename, { write = true; read = false; position = pos :: [] })
+    | Some (filename, v) ->
+        StringMap.replace map identifier
+          (filename, { v with write = true; position = pos :: v.position })
+
+module Expression = struct
+  type t = string -> context -> unit
+
+  let v : t -> t = Fun.id
+
+  include Default.Expression (struct
+    type nonrec t = t
+
+    let default _ map = ignore map
+  end)
+
+  let ident : (S.pos, t) S.variable -> t =
+   fun variable filename map ->
+    (* Update the map and set the read flag *)
+    set_readed variable.pos variable.name filename map
+
+  let literal : S.pos -> t T.literal list -> t =
+   fun pos l filename map ->
+    List.iter l ~f:(function
+      | T.Text t ->
+          set_readed pos ~update_only:true (String.uppercase_ascii t) filename
+            map
+      | T.Expression exprs ->
+          (* When the string contains an expression evaluate it *)
+          exprs filename map)
+
+  let function_ : S.pos -> T.function_ -> t list -> t =
+   fun _ _ exprs filename map -> List.iter ~f:(fun v -> v filename map) exprs
+
+  let uoperator : S.pos -> T.uoperator -> t -> t = fun _ _ t map -> t map
+
+  let boperator : S.pos -> T.boperator -> t -> t -> t =
+   fun _ _ t1 t2 filename map ->
+    t1 filename map;
+    t2 filename map
+end
+
+module Instruction = struct
+  type t = Expression.t
+  (** Internal type used in the evaluation *)
+
+  type t' = t
+
+  let v : t -> t' = Fun.id
+
+  type expression = Expression.t
+
+  let location : S.pos -> string -> t = fun _pos _ _ _ -> ()
+
+  let call : S.pos -> T.keywords -> expression list -> t =
+   fun _ op exprs filename map ->
+    match op with
+    | T.KillVar ->
+        (* Killing a variable does not count as reading it *)
+        ()
+    | _ -> List.iter ~f:(fun v -> v filename map) exprs
+
+  let comment : S.pos -> t = fun _ _ _ -> ()
+  let expression : expression -> t = fun expression map -> expression map
+
+  let fold_clause : (expression, t) S.clause -> t =
+   fun clause filename map ->
+    let _, expr, exprs = clause in
+    let () = expr filename map in
+    let () = List.iter ~f:(fun v -> v filename map) exprs in
+    ()
+
+  let if_ :
+      S.pos ->
+      (expression, t) S.clause ->
+      elifs:(expression, t) S.clause list ->
+      else_:(S.pos * t list) option ->
+      t =
+   fun pos clauses ~elifs ~else_ filename map ->
+    ignore pos;
+    let () = fold_clause clauses filename map in
+    let () = List.iter ~f:(fun v -> fold_clause v filename map) elifs in
+    Option.iter
+      (fun (_, exprs) -> List.iter exprs ~f:(fun v -> v filename map))
+      else_;
+    ()
+
+  let act : S.pos -> label:expression -> t list -> t =
+   fun pos ~label exprs filename map ->
+    ignore pos;
+    ignore label;
+    List.iter ~f:(fun v -> v filename map) exprs
+
+  let assign :
+      S.pos ->
+      (S.pos, expression) S.variable ->
+      T.assignation_operator ->
+      expression ->
+      t =
+   fun pos variable op expr filename map ->
+    ignore op;
+    ignore expr;
+    Option.iter (fun v -> v filename map) variable.index;
+    expr filename map;
+    set_write pos variable.name filename map
+end
+
+module Location = struct
+  type t = unit
+  type instruction = string -> context -> unit
+
+  let v : t -> Report.t list = fun _ -> []
+
+  let location : context -> S.pos -> instruction list -> t =
+   fun context pos instructions ->
+    let file_name = (fst pos).Lexing.pos_fname in
+    ignore pos;
+    ignore context;
+    let () = List.iter ~f:(fun v -> v file_name context) instructions in
+    ()
+end
+
+(** Extract the results from the whole parsing *)
+let finalize : context -> (string * Report.t) list =
+ fun map ->
+  let () =
+    StringMap.filter_map_inplace
+      (fun _ (loc, value) ->
+        match value.read && value.write with
+        | true -> None
+        | false -> Some (loc, value))
+      map
+  in
+
+  let report =
+    StringMap.fold
+      (fun ident (loc, value) report ->
+        match value.read with
+        | false ->
+            List.fold_left value.position ~init:report ~f:(fun report pos ->
+                let msg =
+                  Report.debug pos
+                    (String.concat ~sep:" "
+                       [ "The variable"; ident; "is never read" ])
+                in
+                (loc, msg) :: report)
+        | true -> report)
+      map []
+  in
+  report