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
---
syntax/dune | 2 +-
syntax/report.ml | 40 +++++++
syntax/type_of.ml | 348 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 389 insertions(+), 1 deletion(-)
create mode 100644 syntax/report.ml
create mode 100644 syntax/type_of.ml
(limited to 'syntax')
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