aboutsummaryrefslogtreecommitdiff
path: root/lib/syntax
diff options
context:
space:
mode:
Diffstat (limited to 'lib/syntax')
-rw-r--r--lib/syntax/check.ml429
-rw-r--r--lib/syntax/check.mli53
-rw-r--r--lib/syntax/compose.ml125
-rw-r--r--lib/syntax/dead_end.ml171
-rw-r--r--lib/syntax/dead_end.mli6
-rw-r--r--lib/syntax/default.ml41
-rw-r--r--lib/syntax/dup_test.ml188
-rw-r--r--lib/syntax/dup_test.mli1
-rw-r--r--lib/syntax/get_type.ml121
-rw-r--r--lib/syntax/locations.ml159
-rw-r--r--lib/syntax/nested_strings.ml156
-rw-r--r--lib/syntax/nested_strings.mli1
-rw-r--r--lib/syntax/type_of.ml488
-rw-r--r--lib/syntax/type_of.mli7
-rw-r--r--lib/syntax/write_only.ml217
15 files changed, 0 insertions, 2163 deletions
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml
deleted file mode 100644
index b642945..0000000
--- a/lib/syntax/check.ml
+++ /dev/null
@@ -1,429 +0,0 @@
-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.t } -> result
-
-let get : type a. a Id.t -> result -> a option =
- fun typeid (R { value; witness }) ->
- match Id.provably_equal typeid witness with
- | Some Type.Equal -> Some value
- | None -> None
-
-type t =
- | E : {
- module_ :
- (module S.Analyzer
- with type Expression.t = 'a
- and type Expression.t' = 'b
- and type Instruction.t = 'c
- and type Instruction.t' = 'd
- and type Location.t = 'e
- and type context = 'f);
- 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
-
-let build :
- (module S.Analyzer
- with type Expression.t = _
- and type Expression.t' = _
- and type Instruction.t = _
- and type Instruction.t' = _
- and type Location.t = 'a
- and type context = _) ->
- 'a Id.t * t =
- fun module_ ->
- 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
- {
- module_;
- expr_witness;
- expr';
- instr_witness;
- instr';
- location_witness;
- context;
- }
- in
- (location_witness, t)
-
-let get_module : t -> (module S.Analyzer) =
- fun (E { module_; _ }) -> (module_ :> (module S.Analyzer))
-
-module type App = sig
- val t : t array
-end
-
-open StdLabels
-
-module Helper = struct
- type 'a expr_list = { witness : 'a Id.t; values : 'a 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 }
- ~f:(fun (type a) ({ values; witness } : a expr_list) t : a expr_list ->
- match get witness (Array.get t i) with
- | None -> failwith "Does not match"
- | Some value_1 -> { values = value_1 :: values; witness })
- in
- { result with values = result.values }
-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
-
- module Expression : S.Expression with type t' = result array = struct
- type t = result array
- type t' = result array
-
- let literal : S.pos -> t T.literal list -> t =
- fun pos values ->
- Array.mapi A.t ~f:(fun i (E { module_ = (module S); expr_witness; _ }) ->
- (* Map every values to the Checker *)
- let values' =
- List.map values
- ~f:
- (T.map_litteral ~f:(fun expr ->
- Option.get (get expr_witness (Array.get expr i))))
- in
- let value = S.Expression.literal pos values' in
- R { value; witness = expr_witness })
-
- let integer : S.pos -> string -> t =
- fun pos value ->
- Array.map A.t ~f:(fun (E { module_ = (module S); expr_witness; _ }) ->
- let value = S.Expression.integer pos value in
- R { value; witness = expr_witness })
-
- (** Unary operator like [-123] or [+'Text']*)
- let uoperator : S.pos -> T.uoperator -> t -> t =
- fun pos op values ->
- (* Evaluate the nested expression *)
- let results = values in
-
- (* Now evaluate the remaining expression.
-
- Traverse both the module the apply, and the matching expression already
- evaluated.
-
- It’s easer to use [map] and declare [report] as reference instead of
- [fold_left2] and accumulate the report inside the closure, because I
- don’t manage the order of the results.
- *)
- let results =
- Array.map2 A.t results
- ~f:(fun (E { module_ = (module S); expr_witness; _ }) value ->
- match get expr_witness value with
- | None -> failwith "Does not match"
- | Some value ->
- (* Evaluate the single expression *)
- let value = S.Expression.uoperator pos op value in
- R { witness = expr_witness; value })
- in
- results
-
- (** Basically the same as uoperator, but operate over two operands instead
- of a single one. *)
- let boperator : S.pos -> T.boperator -> t -> t -> t =
- fun pos op expr1 expr2 ->
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
- match
- ( get expr_witness (Array.get expr1 i),
- get expr_witness (Array.get expr2 i) )
- with
- | Some value_1, Some value_2 ->
- let value = S.Expression.boperator pos op value_1 value_2 in
- R { witness = expr_witness; value }
- | _ -> failwith "Does not match")
-
- (** Call a function. The functions list is hardcoded in lib/lexer.mll *)
- let function_ : S.pos -> T.function_ -> t list -> t =
- fun pos func args ->
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
- (* Extract the arguments for each module *)
- let args_i = List.rev (Helper.expr_i args expr_witness i).values in
- let value = S.Expression.function_ pos func args_i in
- R { witness = expr_witness; value })
-
- let ident : (S.pos, t) S.variable -> t =
- fun { pos : S.pos; name : string; index : t option } ->
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in
-
- match index with
- | None ->
- (* Easest case, just return the plain ident *)
- let value = S.Expression.ident { pos; name; index = None } in
- R { witness = expr_witness; value }
- | Some t -> (
- match get expr_witness (Array.get t i) with
- | None -> failwith "Does not match"
- | Some value_1 ->
- let value =
- S.Expression.ident { pos; name; index = Some value_1 }
- in
- R { witness = expr_witness; value }))
-
- (** Convert each internal represention for the expression into its external
- representation *)
- let v : t -> t' =
- fun t ->
- let result =
- Array.map2 A.t t
- ~f:(fun (E { module_ = (module S); expr_witness; expr'; _ }) result ->
- match get expr_witness result with
- | None -> failwith "Does not match"
- | Some value ->
- let value = S.Expression.v value in
- R { witness = expr'; value })
- in
- result
- end
-
- module Instruction :
- S.Instruction
- with type expression = Expression.t'
- and type t' = result array = struct
- type expression = Expression.t'
- type t = result array
- type t' = result array
-
- let location : S.pos -> string -> t =
- fun pos label ->
- Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
- let value = S.Instruction.location pos label in
- R { value; witness = instr_witness })
-
- let comment : S.pos -> t =
- fun pos ->
- Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) ->
- let value = S.Instruction.comment pos in
- R { value; witness = instr_witness })
-
- let expression : expression -> t =
- fun expr ->
- Array.map2 A.t expr
- ~f:(fun (E { module_ = (module S); instr_witness; expr'; _ }) result ->
- match get expr' result with
- | None -> failwith "Does not match"
- | Some value ->
- (* The evaluate the instruction *)
- let value = S.Instruction.expression value in
- R { value; witness = instr_witness })
-
- let call : S.pos -> T.keywords -> expression list -> t =
- fun pos keyword args ->
- (* The arguments are given like an array of array. Each expression is
- actually the list of each expression in the differents modules. *)
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); expr'; instr_witness; _ }) =
- Array.get A.t i
- in
-
- let values = List.rev (Helper.expr_i args expr' i).values in
-
- let value = S.Instruction.call pos keyword values in
- R { witness = instr_witness; value })
-
- let act : S.pos -> label:expression -> t list -> t =
- fun pos ~label instructions ->
- Array.init len ~f:(fun i ->
- let (E { module_ = (module S); instr_witness; expr'; _ }) =
- Array.get A.t i
- in
- let values =
- List.rev (Helper.expr_i instructions instr_witness i).values
- in
-
- match get expr' (Array.get label i) with
- | None -> failwith "Does not match"
- | Some label_i ->
- let value = S.Instruction.act pos ~label:label_i values in
- R { witness = instr_witness; value })
-
- (* I think it’s one of the longest module I’ve ever written in OCaml… *)
-
- let assign :
- S.pos ->
- (S.pos, expression) S.variable ->
- T.assignation_operator ->
- expression ->
- t =
- fun pos { pos = var_pos; name; index } op expression ->
- Array.init len ~f:(fun i ->
- let (E { module_ = (module A); instr_witness; expr'; _ }) =
- Array.get A.t i
- in
-
- let index_i =
- Option.map
- (fun expression ->
- Option.get (get expr' (Array.get expression i)))
- index
- in
- let variable = S.{ pos = var_pos; name; index = index_i } in
-
- match get expr' (Array.get expression i) with
- | None -> failwith "Does not match"
- | Some value ->
- let value = A.Instruction.assign pos variable op value in
-
- R { value; witness = instr_witness })
-
- let rebuild_clause :
- type a b.
- int ->
- a Id.t ->
- b Id.t ->
- S.pos * result array * result array list ->
- (b, a) S.clause =
- fun i instr_witness expr' clause ->
- let pos_clause, expr_clause, ts = clause in
- match get expr' (Array.get expr_clause i) with
- | None -> failwith "Does not match"
- | Some value ->
- let ts = Helper.expr_i ts instr_witness i in
- let ts = List.rev ts.values in
- let clause = (pos_clause, value, ts) in
- clause
-
- let if_ :
- S.pos ->
- (expression, t) S.clause ->
- elifs:(expression, t) S.clause list ->
- else_:(S.pos * t list) option ->
- t =
- fun pos clause ~elifs ~else_ ->
- (* First, apply the report for all the instructions *)
- let else_ =
- match else_ with
- | None -> None
- | Some (pos, instructions) -> Some (pos, instructions)
- in
- Array.init len ~f:(fun i ->
- let (E { module_ = (module A); instr_witness; expr'; _ }) =
- Array.get A.t i
- in
-
- let clause = rebuild_clause i instr_witness expr' clause
- and elifs = List.map elifs ~f:(rebuild_clause i instr_witness expr')
- and else_ =
- match else_ with
- | None -> None
- | Some (pos, instructions) ->
- let elses = Helper.expr_i instructions instr_witness i in
- Some (pos, List.rev elses.values)
- in
-
- let value = A.Instruction.if_ pos clause ~elifs ~else_ in
- R { value; witness = instr_witness })
-
- (** This code is almost a copy/paste from Expression.v but I did not found
- a way to factorize it. *)
- let v : t -> t' =
- fun t ->
- let result =
- Array.map2 A.t t
- ~f:(fun
- (E { module_ = (module S); instr_witness; instr'; _ }) result ->
- match get instr_witness result with
- | None -> failwith "Does not match"
- | Some value ->
- let value = S.Instruction.v value in
- R { witness = instr'; value })
- in
- result
- end
-
- module Location :
- 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 : 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; 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 local_context pos instructions in
- R { value; witness = location_witness })
- in
- result
-
- let v : t -> Report.t list =
- fun args ->
- let report = ref [] in
- let () =
- Array.iteri args ~f:(fun i result ->
- let (E { module_ = (module A); location_witness; _ }) =
- Array.get A.t i
- in
- match get location_witness result with
- | None -> failwith "Does not match"
- | Some value ->
- let re = A.Location.v value in
- report := List.rev_append re !report)
- in
- !report
- end
-end
diff --git a/lib/syntax/check.mli b/lib/syntax/check.mli
deleted file mode 100644
index 7db719d..0000000
--- a/lib/syntax/check.mli
+++ /dev/null
@@ -1,53 +0,0 @@
-(** This module is a meta-checker. It will take many checkers and aggregate
- their result together before providing an unified result.
-
- The modules required to be declared before being used, using the [build]
- method, and provided as an array :
-
- {[
- let _, e1 = build (module …)
- let _, e2 = build (module …)
-
- module Check = Make (struct
- let t = [| e1; e2 |]
- end)
- ]}
-*)
-
-module Id : sig
- type 'a t
- (** The type created on-the-fly. *)
-end
-
-type t
-(** Type of check to apply *)
-
-val build :
- (module S.Analyzer
- with type Expression.t = _
- and type Expression.t' = _
- and type Instruction.t = _
- and type Instruction.t' = _
- and type Location.t = 'a
- and type context = _) ->
- '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. *)
-
-val get_module : t -> (module S.Analyzer)
-
-type result
-
-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.
- *)
-
-module Make (A : sig
- val t : t array
-end) : sig
- include S.Analyzer with type Location.t = result array
-end
-[@@warning "-67"]
diff --git a/lib/syntax/compose.ml b/lib/syntax/compose.ml
deleted file mode 100644
index 8c92ed0..0000000
--- a/lib/syntax/compose.ml
+++ /dev/null
@@ -1,125 +0,0 @@
-(** Build a module with the result from another one module *)
-
-open StdLabels
-
-(** Make a module lazy *)
-module Lazier (E : S.Expression) :
- S.Expression with type t' = E.t' Lazy.t and type t = E.t Lazy.t = struct
- type t = E.t Lazy.t
- type t' = E.t' Lazy.t
-
- let v : E.t Lazy.t -> E.t' Lazy.t = Lazy.map E.v
- let integer : S.pos -> string -> t = fun pos i -> lazy (E.integer pos i)
-
- let ident : (S.pos, t) S.variable -> t =
- fun { pos; name : string; index : t option } ->
- lazy (E.ident { pos; name; index = Option.map Lazy.force index })
-
- let literal : S.pos -> t T.literal list -> t =
- fun pos litts ->
- lazy
- (let e_litts = List.map litts ~f:(T.map_litteral ~f:Lazy.force) in
- E.literal pos e_litts)
-
- let function_ : S.pos -> T.function_ -> t list -> t =
- fun pos f e ->
- lazy
- (let e' = List.map ~f:Lazy.force e in
- E.function_ pos f e')
-
- let uoperator : S.pos -> T.uoperator -> t -> t =
- fun pos op t ->
- let t' = lazy (E.uoperator pos op (Lazy.force t)) in
- t'
-
- let boperator : S.pos -> T.boperator -> t -> t -> t =
- fun pos op t1 t2 ->
- let t' = lazy (E.boperator pos op (Lazy.force t1) (Lazy.force t2)) in
- t'
-end
-
-(** Build an expression module with the result from another expression. The
- signature of the fuctions is a bit different, as they all receive the
- result from the previous evaluated element in argument. *)
-module Expression (E : S.Expression) = struct
- module type SIG = sig
- type t
- type t'
-
- (* Override the type [t] in the definition of all the functions. The
- signatures differs a bit from the standard signature as they get the
- result from E.t in last argument *)
-
- val ident : (S.pos, E.t' Lazy.t * t) S.variable -> E.t' Lazy.t -> t
- val integer : S.pos -> string -> E.t' Lazy.t -> t
- val literal : S.pos -> (E.t' Lazy.t * t) T.literal list -> E.t' Lazy.t -> t
-
- val function_ :
- S.pos -> T.function_ -> (E.t' Lazy.t * t) list -> E.t' Lazy.t -> t
-
- val uoperator : S.pos -> T.uoperator -> E.t' Lazy.t * t -> E.t' Lazy.t -> t
-
- val boperator :
- S.pos ->
- T.boperator ->
- E.t' Lazy.t * t ->
- E.t' Lazy.t * t ->
- E.t' Lazy.t ->
- t
-
- val v : E.t' Lazy.t * t -> t'
- (** Convert from the internal representation to the external one. *)
- end
-
- (* Create a lazy version of the module *)
- module E = Lazier (E)
-
- module Make (M : SIG) : S.Expression with type t' = M.t' = struct
- type t = E.t * M.t
- type t' = M.t'
-
- let v' : E.t -> E.t' = E.v
- let v : t -> t' = fun (type_of, v) -> M.v (v' type_of, v)
-
- let ident : (S.pos, t) S.variable -> t =
- fun { pos; name : string; index : t option } ->
- let t' = E.ident { pos; name; index = Option.map fst index } in
- let index' = Option.map (fun (e, m) -> (v' e, m)) index in
- (t', M.ident { pos; name; index = index' } (v' t'))
-
- let integer : S.pos -> string -> t =
- fun pos i ->
- let t' = E.integer pos i in
- (t', M.integer pos i (v' t'))
-
- let literal : S.pos -> t T.literal list -> t =
- fun pos litts ->
- let litts' =
- List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (v' e, m)))
- in
-
- let t' =
- let e_litts = List.map litts ~f:(T.map_litteral ~f:fst) in
- E.literal pos e_litts
- in
- (t', M.literal pos litts' (v' t'))
-
- let function_ : S.pos -> T.function_ -> t list -> t =
- fun pos f expressions ->
- let e = List.map ~f:fst expressions
- and expressions' = List.map ~f:(fun (e, m) -> (v' e, m)) expressions in
-
- let t' = E.function_ pos f e in
- (t', M.function_ pos f expressions' (v' t'))
-
- let uoperator : S.pos -> T.uoperator -> t -> t =
- fun pos op (t, expr) ->
- let t' = E.uoperator pos op t in
- (t', M.uoperator pos op (v' t, expr) (v' t'))
-
- let boperator : S.pos -> T.boperator -> t -> t -> t =
- fun pos op (t1, expr1) (t2, expr2) ->
- let t' = E.boperator pos op t1 t2 in
- (t', M.boperator pos op (v' t1, expr1) (v' t2, expr2) (v' t'))
- end
-end
diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml
deleted file mode 100644
index c0dbc58..0000000
--- a/lib/syntax/dead_end.ml
+++ /dev/null
@@ -1,171 +0,0 @@
-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
-
- 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
diff --git a/lib/syntax/dead_end.mli b/lib/syntax/dead_end.mli
deleted file mode 100644
index 451fe58..0000000
--- a/lib/syntax/dead_end.mli
+++ /dev/null
@@ -1,6 +0,0 @@
-(** Checker looking for the dead ends in the source.
-
- A dead end is a state where the user does not have any action.
- *)
-
-include S.Analyzer
diff --git a/lib/syntax/default.ml b/lib/syntax/default.ml
deleted file mode 100644
index d345401..0000000
--- a/lib/syntax/default.ml
+++ /dev/null
@@ -1,41 +0,0 @@
-(** Default implementation which does nothing.
-
-This module is expected to be used when you only need to implement an analyze
-over a limited part of the whole syntax. *)
-
-module type T = sig
- type t
-
- val default : t
-end
-
-module Expression (T' : T) = struct
- (**
- Describe a variable, using the name in capitalized text, and an optionnal
- index.
-
- 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
-
- (*
- Basic values, text, number…
- *)
-
- let integer : S.pos -> string -> T'.t = fun _ _ -> T'.default
- let literal : S.pos -> T'.t T.literal list -> T'.t = fun _ _ -> T'.default
-
- (** Call a function. The functions list is hardcoded in lib/lexer.mll *)
- let function_ : S.pos -> T.function_ -> T'.t list -> T'.t =
- fun _ _ _ -> T'.default
-
- (** Unary operator like [-123] or [+'Text']*)
- let uoperator : S.pos -> T.uoperator -> T'.t -> T'.t = fun _ _ _ -> T'.default
-
- (** Binary operator, for a comparaison, or an operation *)
- let boperator : S.pos -> T.boperator -> T'.t -> T'.t -> T'.t =
- fun _ _ _ _ -> T'.default
-end
diff --git a/lib/syntax/dup_test.ml b/lib/syntax/dup_test.ml
deleted file mode 100644
index 20faa56..0000000
--- a/lib/syntax/dup_test.ml
+++ /dev/null
@@ -1,188 +0,0 @@
-(** This module check for duplicated tests in the source.contents
-
-
- This in intended to identify the copy/paste errors, where one location
- check for the same arguments twice or more.
- *)
-
-open StdLabels
-
-let identifier = "duplicate_test"
-let description = "Check for duplicate tests"
-let is_global = false
-let active = ref true
-
-type context = unit
-
-let initialize = Fun.id
-let finalize () = []
-
-module Expression = Tree.Expression
-
-(** Build a Hashtbl over the expression, ignoring the location in the
- expression *)
-module Table = Hashtbl.Make (struct
- type t = Expression.t'
-
- let equal : t -> t -> bool = Tree.Expression.eq (fun _ _ -> true)
- let hash : t -> int = Tree.Expression.hash (fun _ -> 0)
-end)
-
-module Instruction = struct
- type state = {
- predicates : (Expression.t' * S.pos) list;
- duplicates : (Expression.t' * S.pos list) list;
- }
- (** Keep the list of all the predicates and their position in a block, and
- the list of all the identified duplicated values. *)
-
- type t = state
- type t' = state
-
- let v : t -> t' = fun t -> t
- let default = { predicates = []; duplicates = [] }
-
- (** 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
-
- let check_duplicates :
- (Expression.t' * S.pos) list -> (Expression.t' * S.pos list) list =
- fun predicates ->
- let table = Table.create 5 in
- let () = List.to_seq predicates |> Table.add_seq table in
-
- Table.to_seq_keys table
- |> Seq.group (Tree.Expression.eq (fun _ _ -> true))
- |> Seq.filter_map (fun keys ->
- (* Only take the first element for each group, we don’t need to
- repeat the key *)
- match Seq.uncons keys with
- | None -> None
- | Some (hd, _) -> (
- match Table.find_all table hd with
- | [] | _ :: [] -> None
- | other -> Some (hd, other)))
- |> List.of_seq
-
- (** Evaluate a clause.
- This function does two things :
- - report all errors from the bottom to top
- - add the clause in the actual level *)
- let predicate_of_clause : ?pos:S.pos -> t -> (Expression.t', t) S.clause -> t
- =
- fun ?pos t (pos2, predicate, blocks) ->
- let pos = Option.value ~default:pos2 pos in
-
- (* Remove the clauses using the function rnd because they repeating the
- same clause can generate a different result *)
- let should_discard =
- Tree.Expression.exists predicate ~f:(function
- | Tree.Ast.Function (_, T.Rand, _) | Tree.Ast.Function (_, T.Rnd, _) ->
- true
- | _ -> false)
- in
-
- {
- predicates =
- (match should_discard with
- | false -> (predicate, pos) :: t.predicates
- | true -> t.predicates);
- duplicates =
- List.fold_left blocks ~init:t.duplicates ~f:(fun acc t ->
- List.rev_append t.duplicates acc);
- }
-
- 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_ ->
- ignore else_;
- (* Collect all the if clauses from this block, wait for the parent block to
- check each case for duplicates. *)
- let init = predicate_of_clause ~pos default clause in
- let state = List.fold_left elifs ~init ~f:predicate_of_clause in
- {
- state with
- duplicates = check_duplicates state.predicates @ state.duplicates;
- }
-
- let act : S.pos -> label:Expression.t' -> t list -> t =
- fun _pos ~label expressions ->
- ignore label;
- (* Collect all the elements reported from bottom to up. *)
- List.fold_left ~init:default expressions ~f:(fun state ex ->
- {
- predicates = [];
- duplicates = List.rev_append ex.duplicates state.duplicates;
- })
-
- let assign :
- S.pos ->
- (S.pos, Expression.t') S.variable ->
- T.assignation_operator ->
- Expression.t' ->
- t =
- fun _ _ _ _ -> default
-
- let call : S.pos -> T.keywords -> Expression.t' list -> t =
- fun _ _ _ -> default
-end
-
-module Location = struct
- type t = (Expression.t' * S.pos list) list
-
- type context = unit
- (** No context *)
-
- (** Check if the given expression is involving the variable ARGS or $ARGS *)
- let is_args : Expression.t' -> bool = function
- | Tree.Ast.Ident { name; _ } ->
- String.equal name "ARGS" || String.equal name "$ARGS"
- | _ -> false
-
- let location : context -> S.pos -> Instruction.t' list -> t =
- fun () _ block ->
- (* Filter the tests from the top level and only keep them testing ARGS *)
- let duplicates =
- List.map block ~f:(fun t ->
- List.filter_map t.Instruction.predicates ~f:(fun v ->
- match (Tree.Expression.exists ~f:is_args) (fst v) with
- | true -> Some v
- | false -> None))
- |> List.concat |> Instruction.check_duplicates
- in
- List.fold_left ~init:duplicates block ~f:(fun state ex ->
- List.rev_append ex.Instruction.duplicates state)
-
- (** Create the report message *)
- let v' : Expression.t' * S.pos list -> Report.t option =
- fun (expr, pos) ->
- ignore expr;
- match (List.sort ~cmp:Report.compare_pos) pos with
- | [] -> None
- | _ :: [] -> None
- | hd :: tl ->
- let message =
- Format.asprintf "This case is duplicated line(s) %a"
- (Format.pp_print_list
- ~pp_sep:(fun f () -> Format.pp_print_char f ',')
- Report.pp_line)
- tl
- in
-
- (* Report all the messages as error. They do not break the game, but
- there is no question if it should *)
- Some (Report.error hd message)
-
- let v : t -> Report.t list =
- fun t -> List.filter_map t ~f:v' |> List.sort_uniq ~cmp:Report.compare
-end
diff --git a/lib/syntax/dup_test.mli b/lib/syntax/dup_test.mli
deleted file mode 100644
index 38e3a1b..0000000
--- a/lib/syntax/dup_test.mli
+++ /dev/null
@@ -1 +0,0 @@
-include S.Analyzer
diff --git a/lib/syntax/get_type.ml b/lib/syntax/get_type.ml
deleted file mode 100644
index b22f53c..0000000
--- a/lib/syntax/get_type.ml
+++ /dev/null
@@ -1,121 +0,0 @@
-open StdLabels
-
-type type_of =
- | Integer (** A numeric value *)
- | Bool (** A boolean, not a real type *)
- | String (** String value *)
- | NumericString
- [@printer fun fmt _ -> Format.pp_print_string fmt "Integer as String"]
- (** String containing a numeric value *)
-[@@deriving show { with_path = false }, eq]
-
-type t = Variable of type_of | Raw of type_of [@@deriving show, eq]
-type t' = t
-
-let v = Fun.id
-let get_type : t -> type_of = function Raw r -> r | Variable r -> r
-
-let map : t -> type_of -> t =
- fun t type_of ->
- match t with Raw _ -> Raw type_of | Variable _ -> Variable type_of
-
-let get_nature : t -> t -> type_of -> t =
- fun t1 t2 type_of ->
- match (t1, t2) with
- | Variable _, _ -> Variable type_of
- | _, Variable _ -> Variable type_of
- | Raw _, Raw _ -> Raw type_of
-
-let integer : S.pos -> string -> t = fun _ _ -> Raw Integer
-
-let ident : (S.pos, 'any) S.variable -> t =
- fun var ->
- match var.name.[0] with '$' -> Variable String | _ -> Variable Integer
-
-let literal : S.pos -> t T.literal list -> t =
- fun pos values ->
- ignore pos;
- let init = None in
- let typed =
- List.fold_left values ~init ~f:(fun state -> function
- | T.Text t -> (
- (* Tranform the type, but keep the information is it’s a raw data
- or a variable one *)
- let nature = Option.value ~default:(Raw Integer) state in
- match (Option.map get_type state, int_of_string_opt t) with
- | None, Some _
- | Some Integer, Some _
- | Some NumericString, Some _
- | Some Bool, Some _ ->
- Some (map nature NumericString)
- | _, _ ->
- if String.equal "" t then
- (* If the text is empty, ignore it *)
- state
- else Some (map nature String))
- | T.Expression t -> (
- let nature = Option.value ~default:(Raw Integer) state in
- match (Option.map get_type state, get_type t) with
- | None, Integer | Some NumericString, Integer ->
- Some (get_nature nature t NumericString)
- | _ -> Some (map nature String)))
- in
- let result = Option.value ~default:(Raw String) typed in
- result
-
-let uoperator : S.pos -> T.uoperator -> t -> t =
- fun pos operator t ->
- ignore pos;
- match operator with Add -> t | Neg | No -> Raw Integer
-
-let boperator : S.pos -> T.boperator -> t -> t -> t =
- fun pos operator t1 t2 ->
- ignore pos;
- match operator with
- | T.Plus -> (
- match (get_type t1, get_type t2) with
- | Integer, Integer -> get_nature t1 t2 Integer
- | String, _ -> get_nature t1 t2 String
- | _, String -> get_nature t1 t2 String
- | (_ as t), Bool -> get_nature t1 t2 t
- | Bool, (_ as t) -> get_nature t1 t2 t
- | (_ as t), NumericString -> get_nature t1 t2 t
- | NumericString, (_ as t) -> get_nature t1 t2 t)
- | T.Eq | T.Neq -> get_nature t1 t2 Bool
- | T.Mod | T.Minus | T.Product | T.Div -> get_nature t1 t2 Integer
- | T.And | T.Or -> get_nature t1 t2 Bool
- | Lt | Gte | Lte | Gt -> get_nature t1 t2 Bool
-
-let function_ : S.pos -> T.function_ -> t list -> t =
- fun pos function_ params ->
- ignore pos;
- match function_ with
- | Dyneval | Dyneval' -> Variable NumericString
- | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Getobj | Instr | Isplay ->
- Variable Integer
- | Desc' | Getobj' -> Variable String
- | Func | Func' -> Variable NumericString
- | Iif | Iif' -> ( match params with _ :: t :: _ -> t | _ -> Raw Bool)
- | Input | Input' -> Variable NumericString
- | Isnum -> Raw Bool
- | Lcase | Lcase' | Ucase | Ucase' -> Raw String
- | Len -> Raw Integer
- | Loc -> Variable Bool
- | Max | Max' | Min | Min' -> (
- try List.hd params with Failure _ -> Raw Bool)
- | Mid | Mid' -> Variable String
- | Msecscount -> Raw Integer
- | Rand -> Raw Integer
- | Replace -> Variable String
- | Replace' -> Variable String
- | Rgb -> Raw Integer
- | Rnd -> Raw Integer
- | Selact -> Variable String
- | Str | Str' -> Raw String
- | Strcomp -> Raw Bool
- | Strfind -> Variable String
- | Strfind' -> Variable String
- | Strpos -> Raw Integer
- | Trim -> Variable String
- | Trim' -> Variable String
- | Val -> Raw Integer
diff --git a/lib/syntax/locations.ml b/lib/syntax/locations.ml
deleted file mode 100644
index 17f33bd..0000000
--- a/lib/syntax/locations.ml
+++ /dev/null
@@ -1,159 +0,0 @@
-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
deleted file mode 100644
index dee7af0..0000000
--- a/lib/syntax/nested_strings.ml
+++ /dev/null
@@ -1,156 +0,0 @@
-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
- type t = Report.t list
- type t' = Report.t list
-
- let v : Get_type.t Lazy.t * t -> t' = snd
-
- (** Identify the expressions reprented as string. That’s here that the report
- are added.
-
- All the rest of the module only push thoses warning to the top level. *)
- let literal :
- S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t
- =
- fun pos content _type_of ->
- match content with
- | [ T.Expression (t', _); T.Text "" ] -> (
- match Get_type.get_type (Lazy.force t') with
- | Get_type.Integer -> []
- | _ ->
- let msg = Report.debug pos "This expression can be simplified" in
- [ msg ])
- | _ -> []
-
- let ident :
- (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t =
- fun variable _type_of ->
- match variable.index with None -> [] | Some (_, t) -> t
-
- let integer : S.pos -> string -> Get_type.t Lazy.t -> t =
- fun pos t _type_of ->
- ignore pos;
- ignore t;
- []
-
- let function_ :
- S.pos ->
- T.function_ ->
- (Get_type.t Lazy.t * t) list ->
- Get_type.t Lazy.t ->
- t =
- fun pos f expressions _type_of ->
- ignore pos;
- ignore f;
- let exprs =
- List.fold_left ~init:[] expressions ~f:(fun acc el ->
- List.rev_append (snd el) acc)
- in
- exprs
-
- let uoperator :
- S.pos -> T.uoperator -> Get_type.t Lazy.t * t -> Get_type.t Lazy.t -> t =
- fun pos op r _type_of ->
- ignore op;
- ignore pos;
- snd r
-
- let boperator :
- S.pos ->
- T.boperator ->
- Get_type.t Lazy.t * t ->
- Get_type.t Lazy.t * t ->
- Get_type.t Lazy.t ->
- t =
- fun pos op (_, r1) (_, r2) _type_of ->
- ignore pos;
- ignore op;
- r1 @ r2
-end)
-
-module Instruction :
- S.Instruction with type t' = Report.t list and type expression = Expression.t' =
-struct
- type t = Report.t list
- (** Internal type used in the evaluation *)
-
- type t' = t
-
- let v : t -> t' = Fun.id
-
- type expression = Expression.t'
-
- let call : S.pos -> T.keywords -> expression list -> t =
- fun pos k exprs ->
- ignore pos;
- ignore k;
- List.concat exprs
-
- let location : S.pos -> string -> t = fun _ _ -> []
- let comment : S.pos -> t = fun _ -> []
- let expression : expression -> t = Fun.id
-
- let act : S.pos -> label:expression -> t list -> t =
- fun pos ~label instructions ->
- ignore pos;
- List.concat (label :: instructions)
-
- let fold_clause : (expression, t) S.clause -> t =
- fun (_pos1, expression, ts) -> List.concat (expression :: ts)
-
- let if_ :
- S.pos ->
- (expression, t) S.clause ->
- elifs:(expression, t) S.clause list ->
- else_:(S.pos * t list) option ->
- t =
- fun pos clause ~elifs ~else_ ->
- ignore pos;
-
- let init =
- match else_ with
- | None -> fold_clause clause
- | Some (_, ts) -> List.rev_append (fold_clause clause) (List.concat ts)
- in
-
- List.fold_left elifs ~init ~f:(fun t clause ->
- List.rev_append (fold_clause clause) t)
-
- let assign :
- S.pos ->
- (S.pos, expression) S.variable ->
- T.assignation_operator ->
- expression ->
- t =
- fun pos variable op expression ->
- ignore pos;
- ignore op;
- match variable.index with
- | None -> expression
- | Some v -> List.rev_append v expression
-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 =
- fun () pos intructions ->
- ignore pos;
- List.concat intructions
-end
diff --git a/lib/syntax/nested_strings.mli b/lib/syntax/nested_strings.mli
deleted file mode 100644
index 38e3a1b..0000000
--- a/lib/syntax/nested_strings.mli
+++ /dev/null
@@ -1 +0,0 @@
-include S.Analyzer
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
deleted file mode 100644
index 97b7f91..0000000
--- a/lib/syntax/type_of.ml
+++ /dev/null
@@ -1,488 +0,0 @@
-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 }
-
- module DynType = struct
- type nonrec t = Get_type.t -> Get_type.t
- (** Dynamic type is a type unknown during the code.
-
- For example, the equality operator accept either Integer or String, but
- we expect that both sides of the equality uses the same type.*)
-
- (** Build a new dynamic type *)
- let t : unit -> t =
- fun () ->
- let stored = ref None in
- fun t ->
- match !stored with
- | None ->
- stored := Some t;
- t
- | Some t -> t
- end
-
- (** Declare an argument for a function.
-
- - Either we already know the type and we just have to compare.
- - Either the type shall constrained by another one
- - Or we have a variable number of arguments. *)
- type argument =
- | Fixed of Get_type.type_of
- | Dynamic of DynType.t
- | Variable of argument
-
- let compare :
- ?level:Report.level ->
- strict:bool ->
- Get_type.type_of ->
- argument_repr ->
- Report.t list ->
- Report.t list =
- fun ?(level = Report.Warn) ~strict expected actual report ->
- let equal =
- match (expected, actual.t) with
- (* Strict equality for this ones, always true *)
- | String, Variable String
- | String, Raw String
- | String, Variable NumericString
- | String, Raw NumericString
- | Integer, Variable Integer
- | Integer, Raw Integer
- | NumericString, Variable NumericString
- | NumericString, Raw NumericString
- | Bool, Raw Bool
- | Bool, Variable Bool
- (* Also include the conversion between bool and integer *)
- | Integer, Raw Bool
- | Integer, Variable Bool
- (* The type NumericString can be used as a generic type in input *)
- | _, Variable NumericString
- | NumericString, Raw String
- | NumericString, Variable String
- | NumericString, Raw Integer
- | NumericString, Variable Integer ->
- true
- | Bool, Variable Integer
- | Bool, Raw Integer
- | String, Variable Integer
- | String, Raw Bool
- | String, Variable Bool
- | Integer, Variable String
- | Integer, Raw NumericString ->
- not strict
- (* Explicit rejected cases *)
- | String, Raw Integer | Integer, Raw String -> false
- | _, _ -> false
- in
- if equal then report
- else
- let result_type = match actual.t with Variable v -> v | Raw r -> r in
- let message =
- Format.asprintf "The type %a is expected but got %a" Get_type.pp_type_of
- expected Get_type.pp_type_of result_type
- in
- Report.message level actual.pos message :: report
-
- let rec compare_parameter :
- strict:bool ->
- ?level:Report.level ->
- argument ->
- argument_repr ->
- Report.t list ->
- Report.t list =
- fun ~strict ?(level = Report.Warn) expected param report ->
- match expected with
- | Fixed t -> compare ~strict ~level t param report
- | Dynamic d ->
- let type_ = match d param.t with Raw r -> r | Variable v -> v in
- compare ~strict ~level type_ param report
- | Variable c -> compare_parameter ~level ~strict c param report
-
- (** Compare the arguments one by one *)
- let compare_args :
- ?strict:bool ->
- ?level:Report.level ->
- S.pos ->
- argument list ->
- argument_repr list ->
- Report.t list ->
- Report.t list =
- fun ?(strict = false) ?(level = Report.Warn) pos expected actuals report ->
- let tl, report =
- List.fold_left actuals ~init:(expected, report)
- ~f:(fun (expected, report) param ->
- match expected with
- | (Variable _ as hd) :: _ ->
- let check = compare_parameter ~strict ~level hd param report in
- (expected, check)
- | hd :: tl ->
- let check = compare_parameter ~strict ~level hd param report in
- (tl, check)
- | [] ->
- let msg = Report.error param.pos "Unexpected argument" in
- ([], msg :: report))
- in
- match tl with
- | [] | Variable _ :: _ -> report
- | _ ->
- let msg = Report.error pos "Not enougth arguments given" in
- msg :: report
-end
-
-module TypeBuilder = Compose.Expression (Get_type)
-
-type t' = { result : Get_type.t Lazy.t; pos : S.pos }
-
-let arg_of_repr : Get_type.t Lazy.t -> S.pos -> Helper.argument_repr =
- fun type_of pos -> { pos; t = Lazy.force type_of }
-
-module TypedExpression = struct
- type nonrec t' = t' * Report.t list
- type state = { pos : S.pos }
- type t = state * Report.t list
-
- let v : Get_type.t Lazy.t * t -> t' =
- fun (type_of, (t, r)) -> ({ result = type_of; pos = t.pos }, r)
-
- (** The variable has type string when starting with a '$' *)
- let ident :
- (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t =
- fun var _type_of ->
- (* Extract the error from the index *)
- let report =
- match var.index with
- | None -> []
- | Some (_, expr) ->
- let _, r = expr in
- r
- in
- ({ pos = var.pos }, report)
-
- let integer : S.pos -> string -> Get_type.t Lazy.t -> t =
- fun pos value _type_of ->
- let int_value = int_of_string_opt value in
-
- let report =
- match int_value with
- | Some 0 -> []
- | Some _ -> []
- | None -> Report.error pos "Invalid integer value" :: []
- in
-
- ({ pos }, report)
-
- let literal :
- S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t
- =
- fun pos values type_of ->
- ignore type_of;
- let init = [] in
- let report =
- List.fold_left values ~init ~f:(fun report -> function
- | T.Text _ -> report
- | T.Expression (_, t) ->
- let report = List.rev_append (snd t) report in
- report)
- in
- ({ pos }, report)
-
- let function_ :
- S.pos ->
- T.function_ ->
- (Get_type.t Lazy.t * t) list ->
- Get_type.t Lazy.t ->
- t =
- fun pos function_ params _type_of ->
- (* Accumulate the expressions and get the results, the report is given in
- the differents arguments, and we build a list with the type of the
- parameters. *)
- let types, report =
- List.fold_left params ~init:([], [])
- ~f:(fun (types, report) (type_of, param) ->
- ignore type_of;
- let t, r = param in
- let arg = arg_of_repr type_of t.pos in
- (arg :: types, r @ report))
- in
- let types = List.rev types and default = { pos } in
-
- match function_ with
- | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Getobj | Instr
- | Isplay ->
- (default, report)
- | Desc' | Dyneval' | Getobj' -> (default, report)
- | Func | Func' -> (default, report)
- | Iif | Iif' ->
- let d = Helper.DynType.t () in
- let expected = Helper.[ Fixed Bool; Dynamic d; Dynamic d ] in
- let report = Helper.compare_args pos expected types report in
- (* Extract the type for the expression *)
- ({ pos }, report)
- | Input | Input' ->
- (* Input should check the result if the variable is a num and raise a
- message in this case.*)
- let expected = Helper.[ Fixed String ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
- | Isnum ->
- let expected = Helper.[ Fixed String ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
- | Lcase | Lcase' | Ucase | Ucase' ->
- let expected = Helper.[ Fixed String ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
- | Len ->
- let expected = Helper.[ Fixed NumericString ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
- | Loc ->
- let expected = Helper.[ Fixed String ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
- | Max | Max' | Min | Min' ->
- let d = Helper.DynType.t () in
- (* All the arguments must have the same type *)
- let expected = Helper.[ Variable (Dynamic d) ] in
- let report = Helper.compare_args pos expected types report in
- ({ pos }, report)
- | Mid | Mid' ->
- let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
- | Msecscount -> (default, report)
- | Rand ->
- let expected = Helper.[ Variable (Fixed Integer) ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
- | Replace -> (default, report)
- | Replace' -> (default, report)
- | Rgb -> (default, report)
- | Rnd ->
- (* No arg *)
- let report = Helper.compare_args pos [] types report in
- (default, report)
- | Selact -> (default, report)
- | Str | Str' ->
- let expected = Helper.[ Variable (Fixed Integer) ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
- | Strcomp -> (default, report)
- | Strfind -> (default, report)
- | Strfind' -> (default, report)
- | Strpos -> (default, report)
- | Trim -> (default, report)
- | Trim' -> (default, report)
- | Val ->
- let expected = Helper.[ Fixed NumericString ] in
- let report = Helper.compare_args pos expected types report in
- (default, report)
-
- (** Unary operator like [-123] or [+'Text']*)
- let uoperator :
- S.pos -> T.uoperator -> Get_type.t Lazy.t * t -> Get_type.t Lazy.t -> t =
- fun pos operator t1 type_of ->
- ignore type_of;
- let type_of, (t, report) = t1 in
- match operator with
- | Add -> (t, report)
- | Neg | No ->
- let types = [ arg_of_repr type_of t.pos ] in
- let expected = Helper.[ Fixed Integer ] in
- let report = Helper.compare_args pos expected types report in
- ({ pos }, report)
-
- let boperator :
- S.pos ->
- T.boperator ->
- Get_type.t Lazy.t * t ->
- Get_type.t Lazy.t * t ->
- Get_type.t Lazy.t ->
- t =
- fun pos operator (type_1, t1) (type_2, t2) type_of ->
- ignore type_of;
- let t1, report1 = t1 in
- let t2, report2 = t2 in
-
- let report = report1 @ report2 in
-
- let types = [ arg_of_repr type_1 t1.pos; arg_of_repr type_2 t2.pos ] in
-
- match operator with
- | T.Plus ->
- (* We cannot really much here, because the (+) function can be used to
- concatenate string or add numbers.
-
- When concatenating, it’s allowed to add an integer and a number.
- *)
- ({ pos }, report)
- | T.Eq | T.Neq | Lt | Gte | Lte | Gt ->
- (* If the expression is '' or 0, we accept the comparaison as if
- instead of raising a warning *)
- let d = Helper.(Dynamic (DynType.t ())) in
- let expected = [ d; d ] in
- (* Compare and report as error if the types are incompatible. If no
- error is reported, try in strict mode, and report as a warning. *)
- let report =
- match
- Helper.compare_args ~level:Error pos expected (List.rev types)
- report
- with
- | [] ->
- Helper.compare_args ~strict:true pos expected (List.rev types)
- report
- | report -> report
- in
- ({ pos }, report)
- | T.Mod | T.Minus | T.Product | T.Div ->
- (* Operation over number *)
- let expected = Helper.[ Fixed Integer; Fixed Integer ] in
- let report = Helper.compare_args pos expected types report in
- ({ pos }, report)
- | T.And | T.Or ->
- (* Operation over booleans *)
- let expected = Helper.[ Fixed Bool; Fixed Bool ] in
- let report = Helper.compare_args pos expected types report in
- ({ pos }, report)
-end
-
-module Expression = TypeBuilder.Make (TypedExpression)
-
-module Instruction = struct
- type t = Report.t list
- type t' = Report.t list
-
- let v : t -> t' = fun local_report -> local_report
-
- type expression = Expression.t'
-
- (** Call for an instruction like [GT] or [*CLR] *)
- let call : S.pos -> T.keywords -> expression list -> t =
- fun _pos _ expressions ->
- List.fold_left expressions ~init:[] ~f:(fun acc a ->
- let _, report = a in
- (List.rev_append report) acc)
-
- let location : S.pos -> string -> t = fun _pos _ -> []
-
- (** Comment *)
- let comment : S.pos -> t = fun _pos -> []
-
- (** Raw expression *)
- let expression : expression -> t = fun expression -> snd expression
-
- (** Helper function used in the [if_] function. *)
- let fold_clause : t -> (expression, t) S.clause -> t =
- fun report (_pos, expr, instructions) ->
- let result, r = expr in
-
- let r2 =
- Helper.compare ~strict:false Get_type.Bool
- (arg_of_repr result.result result.pos)
- []
- in
-
- List.fold_left instructions
- ~init:(r @ r2 @ report)
- ~f:(fun acc a ->
- let report = a in
- (List.rev_append report) acc)
-
- let if_ :
- S.pos ->
- (expression, t) S.clause ->
- elifs:(expression, t) S.clause list ->
- else_:(S.pos * t list) option ->
- t =
- fun _pos clause ~elifs ~else_ ->
- (* Traverse the whole block recursively *)
- let report = fold_clause [] clause in
- let report = List.fold_left elifs ~f:fold_clause ~init:report in
-
- match else_ with
- | None -> report
- | Some (_, instructions) ->
- List.fold_left instructions ~init:report ~f:(fun acc a ->
- let report = a in
- (List.rev_append report) acc)
-
- let act : S.pos -> label:expression -> t list -> t =
- fun _pos ~label instructions ->
- let result, report = label in
- let report =
- Helper.compare ~strict:false Get_type.String
- (arg_of_repr result.result result.pos)
- report
- in
-
- List.fold_left instructions ~init:report ~f:(fun acc a ->
- let report = a in
- (List.rev_append report) acc)
-
- let assign :
- S.pos ->
- (S.pos, expression) S.variable ->
- T.assignation_operator ->
- expression ->
- t =
- fun pos variable op expression ->
- let right_expression, report = expression in
-
- let report' = Option.map snd variable.index |> Option.value ~default:[] in
-
- let report = List.rev_append report' report in
-
- match (op, Get_type.get_type (Lazy.force right_expression.result)) with
- | T.Eq', Get_type.Integer ->
- (* Assigning an intger is allowed in a string variable, but raise a
- warning. *)
- let var_type = Lazy.from_val (Get_type.ident variable) in
- let op1 = arg_of_repr var_type variable.pos in
- let expected = Helper.[ Fixed Integer ] in
- Helper.compare_args ~strict:true ~level:Report.Warn pos expected [ op1 ]
- report
- | _, _ -> (
- let var_type = Lazy.from_val (Get_type.ident variable) in
- let op1 = arg_of_repr var_type variable.pos in
- let op2 = arg_of_repr right_expression.result right_expression.pos in
-
- let d = Helper.DynType.t () in
- (* Every part of the assignation should be the same type *)
- let expected = Helper.[ Dynamic d; Dynamic d ] in
-
- match
- Helper.compare_args ~strict:false ~level:Report.Error pos expected
- [ op1; op2 ] []
- with
- | [] ->
- Helper.compare_args ~strict:true ~level:Report.Warn pos expected
- [ op1; op2 ] report
- | reports -> reports @ report)
-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 =
- fun () _pos instructions ->
- let report =
- List.fold_left instructions ~init:[] ~f:(fun report instruction ->
- let report' = instruction in
- report' @ report)
- in
- report
-end
diff --git a/lib/syntax/type_of.mli b/lib/syntax/type_of.mli
deleted file mode 100644
index 551f9ac..0000000
--- a/lib/syntax/type_of.mli
+++ /dev/null
@@ -1,7 +0,0 @@
-include S.Analyzer
-(** The module [type_of] populate the report with differents inconsistency
- errors in the types.
-
- - Assigning a [string] value in an [integer] variable
- - Comparing a [string] with an [integer]
- - Giving the wrong type in the argument for a function and so one. *)
diff --git a/lib/syntax/write_only.ml b/lib/syntax/write_only.ml
deleted file mode 100644
index ec2e368..0000000
--- a/lib/syntax/write_only.ml
+++ /dev/null
@@ -1,217 +0,0 @@
-(** 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 = (snd 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