From c2fdbf2eb9bac4d92258eda5da3249cd2ef07e55 Mon Sep 17 00:00:00 2001
From: Chimrod <>
Date: Mon, 25 Sep 2023 10:28:06 +0200
Subject: Added a type checker

---
 bin/dune          |   7 +-
 bin/main.ml       |  57 ++++++++-
 syntax/dune       |   2 +-
 syntax/report.ml  |  40 +++++++
 syntax/type_of.ml | 348 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 449 insertions(+), 5 deletions(-)
 create mode 100644 syntax/report.ml
 create mode 100644 syntax/type_of.ml

diff --git a/bin/dune b/bin/dune
index 36f9b41..697402f 100644
--- a/bin/dune
+++ b/bin/dune
@@ -3,4 +3,9 @@
  (name main)
  (libraries 
    qsp_syntax
-   qsp_parser))
+   qsp_parser)
+
+ (preprocess (pps 
+   ppx_deriving.show 
+   ppx_deriving.eq )))
+
diff --git a/bin/main.ml b/bin/main.ml
index 1e8ff45..0026b73 100644
--- a/bin/main.ml
+++ b/bin/main.ml
@@ -1,10 +1,61 @@
+open StdLabels
+module Report = Qsp_syntax.Report
+
+type result = Report.t list [@@deriving show]
+type filters = { level : Report.level option }
+
+module Args = struct
+  let input_files = ref []
+  let usage = "qsp_parser input_file"
+  let anon_fun filename = input_files := filename :: !input_files
+  let level_value = ref None
+
+  let level : string -> unit =
+   fun str_level ->
+    match Report.level_of_string str_level with
+    | Ok level_ -> level_value := Some level_
+    | Error e ->
+        print_endline e;
+        exit 1
+
+  let speclist =
+    [ ("--level", Arg.String level, "Message level [debug, warn, error]") ]
+
+  let parse () =
+    let () = Arg.parse speclist anon_fun usage in
+    let filters = { level = !level_value } in
+    (!input_files, filters)
+end
+
+(** Filter the results given by the analysis *)
+let filter_report : filters -> Report.t list -> Report.t -> Report.t list =
+ fun filters reports r ->
+  let is_ok =
+    match filters.level with
+    | None -> true
+    | Some level -> Report.level_to_enum level >= Report.level_to_enum r.level
+  in
+
+  match is_ok with true -> r :: reports | _ -> reports
+
 let () =
-  let file_name = Sys.argv.(1) in
+  let file_names, filters = Args.parse () in
+  let file_name = List.hd file_names in
+
   let ic = Stdlib.open_in file_name in
   let lexer = Lexing.from_channel ~with_positions:true ic in
-  let result = Qsp_parser.Analyzer.parse (module Qsp_syntax.Tree) lexer in
+  let result = Qsp_parser.Analyzer.parse (module Qsp_syntax.Type_of) lexer in
   match result with
-  | Ok _ -> exit 0
+  | Ok f -> (
+      let report = List.fold_left (f []) ~init:[] ~f:(filter_report filters) in
+
+      (* Display the result *)
+      match report with
+      | [] -> exit 0
+      | _ ->
+          Format.fprintf Format.std_formatter "Location %s@;%a@." file_name
+            pp_result report;
+          exit 1)
   | Error e ->
       Format.fprintf Format.std_formatter "\nError in location %s\n%a" file_name
         Qsp_parser.Analyzer.format_error e;
diff --git a/syntax/dune b/syntax/dune
index 8188de8..666273f 100644
--- a/syntax/dune
+++ b/syntax/dune
@@ -2,5 +2,5 @@
  (name qsp_syntax)
  
  (preprocess (pps 
-   ppx_deriving.show 
+   ppx_deriving.show ppx_deriving.enum
    ppx_deriving.eq )))
diff --git a/syntax/report.ml b/syntax/report.ml
new file mode 100644
index 0000000..0c7d731
--- /dev/null
+++ b/syntax/report.ml
@@ -0,0 +1,40 @@
+(** Report built over the differents analysis in the file *)
+
+type level = Error | Warn | Debug
+[@@deriving show { with_path = false }, enum]
+
+type pos = Lexing.position * Lexing.position
+
+let level_of_string : string -> (level, string) result =
+ fun level ->
+  match String.lowercase_ascii level with
+  | "error" -> Ok Error
+  | "warn" -> Ok Warn
+  | "debug" -> Ok Debug
+  | _ ->
+      Error
+        (Format.sprintf
+           "Unknown report level '%s'. Accepted values are error, warn, debug"
+           level)
+
+let pp_pos : Format.formatter -> pos -> unit =
+ fun f (start_pos, end_pos) ->
+  let start_c = start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol
+  and end_c = end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol
+  and start_line = start_pos.Lexing.pos_lnum
+  and end_line = end_pos.Lexing.pos_lnum in
+
+  if start_line != end_line then
+    Format.fprintf f "Lines %d-%d" start_line end_line
+  else Format.fprintf f "Line %d %d:%d" start_line start_c end_c
+
+type t = { level : level; loc : pos; message : string }
+[@@deriving show { with_path = false }]
+
+let warn : pos -> string -> t =
+ fun loc message -> { level = Warn; loc; message }
+
+let error : pos -> string -> t =
+ fun loc message -> { level = Error; loc; message }
+
+let message level loc message = { level; loc; message }
diff --git a/syntax/type_of.ml b/syntax/type_of.ml
new file mode 100644
index 0000000..5ef90f4
--- /dev/null
+++ b/syntax/type_of.ml
@@ -0,0 +1,348 @@
+open StdLabels
+
+type pos = Lexing.position * Lexing.position
+(** Extract the type for expression *)
+
+module Helper = struct
+  type t = Integer | Bool | String | Any
+  [@@deriving show { with_path = false }]
+
+  type dyn_type = t -> 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 dyn_type : unit -> dyn_type =
+   fun () ->
+    let stored = ref None in
+    fun t ->
+      match !stored with
+      | None ->
+          stored := Some t;
+          t
+      | Some t -> t
+
+  (** 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 t | Dynamic of dyn_type | Variable of argument
+
+  let compare :
+      ?level:Report.level -> t -> pos * t -> Report.t list -> Report.t list =
+   fun ?(level = Report.Warn) expected actual report ->
+    let equal =
+      match (expected, snd actual) with
+      | _, Any -> true
+      | Any, _ -> true
+      | String, String -> true
+      | Integer, Integer -> true
+      | Bool, Bool -> true
+      | Bool, Integer -> true
+      | Integer, Bool -> true
+      | String, Integer -> true
+      | String, Bool -> true
+      | _, String -> false
+    in
+    if equal then report
+    else
+      let message =
+        Format.asprintf "The type %a is expected but got %a" pp expected pp
+          (snd actual)
+      in
+      Report.message level (fst actual) message :: report
+
+  let rec compare_parameter :
+      ?level:Report.level ->
+      argument ->
+      pos * t ->
+      Report.t list ->
+      Report.t list =
+   fun ?(level = Report.Warn) expected param report ->
+    match expected with
+    | Fixed t -> compare ~level t param report
+    | Dynamic d ->
+        let type_ = d (snd param) in
+        compare ~level type_ param report
+    | Variable c -> compare_parameter ~level c param report
+
+  (** Compare the arguments one by one *)
+  let compare_args :
+      ?level:Report.level ->
+      pos ->
+      argument list ->
+      (pos * t) list ->
+      Report.t list ->
+      Report.t list =
+   fun ?(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 ~level hd param report in
+              (expected, check)
+          | hd :: tl ->
+              let check = compare_parameter ~level hd param report in
+              (tl, check)
+          | [] ->
+              let msg = Report.error (fst param) "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 Expression = struct
+  type 'a obs
+
+  type t = {
+    result : Helper.t;
+    report : Report.t list;
+    pos : pos;
+    empty : bool;
+  }
+
+  type repr = Report.t list -> t
+  (** The type repr is a function accepting the report as a first argement.
+      When the report is given, it will be reported into the tree and collected
+      in bottom-top *)
+
+  type variable = { pos : pos; name : string; index : repr option }
+
+  let arg_of_repr : t -> pos * Helper.t =
+   fun { result; report; pos; empty } ->
+    ignore report;
+    ignore empty;
+    (pos, result)
+
+  (** The variable has type string when starting with a '$' *)
+  let ident : variable -> repr =
+   fun var report ->
+    let empty = false in
+    match var.name.[0] with
+    | '$' -> { result = String; report; pos = var.pos; empty }
+    | _ -> { result = Integer; report; pos = var.pos; empty }
+
+  let integer : pos -> string -> repr =
+   fun pos value report ->
+    let empty =
+      match int_of_string_opt value with Some 0 -> true | _ -> false
+    in
+
+    { result = Integer; report; pos; empty }
+
+  let literal : pos -> string -> repr =
+   fun pos value report ->
+    let empty = String.equal String.empty value in
+    { result = String; report; pos; empty }
+
+  let function_ : pos -> T.function_ -> repr list -> repr =
+   fun pos function_ params _acc ->
+    (* 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:([], _acc) ~f:(fun (types, report) param ->
+          let arg = arg_of_repr (param report) in
+          (arg :: types, report))
+    in
+    let types = List.rev types
+    and default = { result = Any; report; pos; empty = false } in
+
+    match function_ with
+    | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Func | Getobj
+    | Instr | Isplay ->
+        { default with result = Integer }
+    | Desc' | Dyneval' | Func' | Getobj' -> { default with result = String }
+    | Iif | Iif' ->
+        let d = Helper.dyn_type () 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 *)
+        let result = d Helper.Bool in
+        { result; report; pos; empty = false }
+    | 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
+        { result = String; report; pos; empty = false }
+    | Isnum ->
+        let expected = Helper.[ Fixed String ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = Bool; report; pos; empty = false }
+    | Lcase | Lcase' | Ucase | Ucase' ->
+        let expected = Helper.[ Fixed String ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = String; report; pos; empty = false }
+    | Len ->
+        let expected = Helper.[ Fixed Any ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = Integer; report; pos; empty = false }
+    | Loc ->
+        let expected = Helper.[ Fixed String ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = Bool; report; pos; empty = false }
+    | Max | Max' | Min | Min' ->
+        let d = Helper.dyn_type () 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
+        let result = d Helper.Bool in
+        { result; report; pos; empty = false }
+    | Mid | Mid' ->
+        let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = String; report; pos; empty = false }
+    | Msecscount -> { result = Integer; report; pos; empty = false }
+    | Rand ->
+        let expected = Helper.[ Variable (Fixed Integer) ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = Integer; report; pos; empty = false }
+    | Replace -> { result = Integer; report; pos; empty = false }
+    | Replace' -> { result = String; report; pos; empty = false }
+    | Rgb -> { result = Integer; report; pos; empty = false }
+    | Qspver | Qspver' | Rnd ->
+        (* No arg *)
+        let report = Helper.compare_args pos [] types report in
+        { result = Integer; report; pos; empty = false }
+    | Selact -> { result = Integer; report; pos; empty = false }
+    | Stattxt -> { result = Integer; report; pos; empty = false }
+    | Stattxt' -> { result = String; report; pos; empty = false }
+    | Str | Str' ->
+        let expected = Helper.[ Variable (Fixed Integer) ] in
+        let report = Helper.compare_args pos expected types report in
+        { default with result = String; report }
+    | Strcomp -> { result = Integer; report; pos; empty = false }
+    | Strfind -> { result = Integer; report; pos; empty = false }
+    | Strfind' -> { result = String; report; pos; empty = false }
+    | Strpos -> { result = Integer; report; pos; empty = false }
+    | Trim -> { result = Integer; report; pos; empty = false }
+    | Trim' -> { result = String; report; pos; empty = false }
+    | Val ->
+        let expected = Helper.[ Fixed Any ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = Integer; report; pos; empty = false }
+
+  (** Unary operator like [-123] or [+'Text']*)
+  let uoperator : pos -> T.uoperator -> repr -> repr =
+   fun pos operator t1 report ->
+    let t = t1 report in
+    match operator with
+    | Add -> t
+    | Neg | No ->
+        let types = [ arg_of_repr t ] in
+        let expected = Helper.[ Fixed Integer ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = Integer; report; pos; empty = false }
+
+  let boperator : pos -> T.boperator -> repr -> repr -> repr =
+   fun pos operator t1 t2 report ->
+    let types = [ arg_of_repr (t1 report); arg_of_repr (t2 report) ] in
+    match operator with
+    | T.Plus ->
+        (* Operation over number *)
+        let d = Helper.(Dynamic (dyn_type ())) in
+        let expected = [ d; d ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = Bool; report; pos; empty = false }
+    | T.Eq | T.Neq | Lt | Gte | Lte | Gt ->
+        let d = Helper.(Dynamic (dyn_type ())) in
+        let expected = [ d; d ] in
+        let report = Helper.compare_args pos expected types report in
+        { result = Bool; report; pos; empty = false }
+    | 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
+        { result = Integer; report; pos; empty = false }
+    | 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
+        { result = Bool; report; pos; empty = false }
+end
+
+module Instruction = struct
+  type repr = Report.t list -> Report.t list
+  type expression = Expression.repr
+  type variable = Expression.variable
+
+  (** Call for an instruction like [GT] or [*CLR] *)
+  let call : pos -> string -> expression list -> repr =
+   fun _pos _ _ report -> report
+
+  let location : pos -> string -> repr = fun _pos _ report -> report
+
+  (** Comment *)
+  let comment : pos -> repr = fun _pos report -> report
+
+  (** Raw expression *)
+  let expression : expression -> repr =
+   fun expression report -> (expression report).report
+
+  type clause = pos * expression * repr list
+
+  let if_ : pos -> clause -> elifs:clause list -> else_:repr list -> repr =
+   fun _pos clause ~elifs ~else_ report ->
+    (* Helper function *)
+    let fold_clause report (_pos, expr, instructions) : Report.t list =
+      let result = expr report in
+      let report =
+        Helper.compare Helper.Bool
+          (Expression.arg_of_repr result)
+          result.Expression.report
+      in
+      List.fold_left instructions ~init:report ~f:(fun report instruction ->
+          instruction report)
+    in
+
+    (* Traverse the whole block recursively *)
+    let report = fold_clause report clause in
+    let report = List.fold_left elifs ~f:fold_clause ~init:report in
+    List.fold_left else_ ~init:report ~f:(fun report instruction ->
+        instruction report)
+
+  let act : pos -> label:expression -> repr list -> repr =
+   fun _pos ~label instructions report ->
+    let result = label report in
+    let report =
+      Helper.compare Helper.String
+        (Expression.arg_of_repr result)
+        result.Expression.report
+    in
+    List.fold_left instructions ~init:report ~f:(fun report instruction ->
+        instruction report)
+
+  let assign : pos -> variable -> T.assignation_operator -> expression -> repr =
+   fun pos variable _ expression report ->
+    let right_expression = expression report in
+    match right_expression.empty with
+    | true -> report
+    | false ->
+        let op1 = Expression.arg_of_repr (Expression.ident variable report) in
+        let report = right_expression.Expression.report in
+        let op2 = Expression.arg_of_repr right_expression in
+
+        let d = Helper.dyn_type () in
+        (* Every part of the assignation should be the same type *)
+        let expected = Helper.[ Dynamic d; Dynamic d ] in
+        Helper.compare_args ~level:Report.Debug pos expected [ op1; op2 ] report
+end
+
+module Location = struct
+  type repr = Instruction.repr
+  type instruction = Instruction.repr
+
+  let location : pos -> instruction list -> repr =
+   fun _pos instructions report ->
+    List.fold_left instructions ~init:report ~f:(fun report instruction ->
+        instruction report)
+end
-- 
cgit v1.2.3