aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChimrod <>2023-11-08 16:30:02 +0100
committerChimrod <>2023-11-09 13:12:45 +0100
commitebf072326e2315ace952c80dbc442198c44faf7d (patch)
tree7f527035eb0627d634768246a0d14e1821d1bdc4
parent1e182dca2972fbd29e50f611dbf12eb28d6cdd95 (diff)
Added a way to compose a test with another one
-rw-r--r--lib/syntax/compose.ml73
-rw-r--r--lib/syntax/get_type.ml105
-rw-r--r--lib/syntax/nested_strings.ml98
-rw-r--r--lib/syntax/t.ml7
-rw-r--r--lib/syntax/type_of.ml230
-rw-r--r--lib/syntax/type_of.mli10
6 files changed, 354 insertions, 169 deletions
diff --git a/lib/syntax/compose.ml b/lib/syntax/compose.ml
new file mode 100644
index 0000000..dcc1a86
--- /dev/null
+++ b/lib/syntax/compose.ml
@@ -0,0 +1,73 @@
+(** Build a module with the result from another one module *)
+
+open StdLabels
+
+(** 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' * t) S.variable -> E.t' -> t
+ val integer : S.pos -> string -> E.t' -> t
+ val literal : S.pos -> (E.t' * t) T.literal list -> E.t' -> t
+ val function_ : S.pos -> T.function_ -> (E.t' * t) list -> E.t' -> t
+ val uoperator : S.pos -> T.uoperator -> E.t' * t -> E.t' -> t
+ val boperator : S.pos -> T.boperator -> E.t' * t -> E.t' * t -> E.t' -> t
+
+ val v : E.t' * t -> t'
+ (** Convert from the internal representation to the external one. *)
+ end
+
+ module Make (M : SIG) : S.Expression with type t' = M.t' = struct
+ type t = E.t * M.t
+ type t' = M.t'
+
+ let v : t -> t' = fun (type_of, v) -> M.v (E.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) -> (E.v e, m)) index in
+ (t', M.ident { pos; name; index = index' } (E.v @@ t'))
+
+ let integer : S.pos -> string -> t =
+ fun pos i ->
+ let t' = E.integer pos i in
+ (t', M.integer pos i (E.v t'))
+
+ let literal : S.pos -> t T.literal list -> t =
+ fun pos litts ->
+ let e_litts = List.map litts ~f:(T.map_litteral ~f:fst) in
+ let litts' =
+ List.map litts ~f:(T.map_litteral ~f:(fun (e, m) -> (E.v e, m)))
+ in
+
+ let t' = E.literal pos e_litts in
+ (t', M.literal pos litts' (E.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) -> (E.v e, m)) expressions in
+
+ let t' = E.function_ pos f e in
+ (t', M.function_ pos f expressions' (E.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 (E.v t, expr) (E.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 (E.v t1, expr1) (E.v t2, expr2) (E.v t'))
+ end
+end
diff --git a/lib/syntax/get_type.ml b/lib/syntax/get_type.ml
new file mode 100644
index 0000000..4aecb01
--- /dev/null
+++ b/lib/syntax/get_type.ml
@@ -0,0 +1,105 @@
+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 }]
+
+type t = Variable of type_of | Raw of type_of
+type t' = t
+
+let v = Fun.id
+let get_type : t -> type_of = function Raw r -> r | Variable r -> r
+
+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 = Raw NumericString in
+ List.fold_left values ~init ~f:(fun state -> function
+ | T.Text t -> (
+ match int_of_string_opt t with Some _ -> state | None -> Raw String)
+ | T.Expression t ->
+ (* Report the warning bottom top *)
+ let result =
+ List.fold_left t ~init:None ~f:(fun _ result -> Some result)
+ in
+ let default = Raw String in
+ let result = Option.value result ~default 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
+ | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Getobj | Instr
+ | Isplay ->
+ Variable Integer
+ | Desc' | Dyneval' | 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
+ | Qspver | Qspver' | Rnd -> Raw Integer
+ | Selact -> Variable String
+ | Stattxt -> Variable String
+ | Stattxt' -> 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/nested_strings.ml b/lib/syntax/nested_strings.ml
index c7b0b83..fcd0b91 100644
--- a/lib/syntax/nested_strings.ml
+++ b/lib/syntax/nested_strings.ml
@@ -4,62 +4,68 @@ let identifier = "escaped_string"
let description = "Check for unnecessary use of expression encoded in string"
let active = ref true
-module Expression : S.Expression with type t' = Report.t list = struct
- type t = Report.t list * Type_of.Expression.t
+module TypeBuilder = Compose.Expression (Get_type)
+
+module Expression = TypeBuilder.Make (struct
+ type t = Report.t list
type t' = Report.t list
- let get_type t = Type_of.Expression.v t |> Type_of.get_type
- let v : t -> t' = Stdlib.fst
+ let v : Get_type.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 -> t T.literal list -> t =
- fun pos content ->
- let type_of =
- List.map content ~f:(function
- | T.Text _ as text -> text
- | T.Expression expr -> T.Expression (List.map ~f:snd expr))
- |> Type_of.Expression.literal pos
- in
-
+ let literal : S.pos -> (Get_type.t * t) T.literal list -> Get_type.t -> t =
+ fun pos content _type_of ->
match content with
- | [ T.Expression [ (_, t') ]; T.Text "" ] -> (
- match get_type t' with
- | Type_of.Helper.Integer -> ([], type_of)
+ | [ T.Expression [ (t', _) ]; T.Text "" ] -> (
+ match Get_type.get_type t' with
+ | Get_type.Integer -> []
| _ ->
let msg = Report.debug pos "This expression can be simplified" in
- ([ msg ], type_of))
- | _ -> ([], type_of)
-
- let ident : (S.pos, t) S.variable -> t =
- fun { pos; name : string; index : t option } ->
- match index with
- | None ->
- let type_ = Type_of.Expression.ident { pos; name; index = None } in
- ([], type_)
- | Some (v, t') ->
- let type_ = Type_of.Expression.ident { pos; name; index = Some t' } in
- (v, type_)
-
- let integer : S.pos -> string -> t =
- fun pos t -> ([], Type_of.Expression.integer pos t)
-
- let function_ : S.pos -> T.function_ -> t list -> t =
- fun pos f expressions ->
- let r, t = List.split expressions in
-
- let type_of = Type_of.Expression.function_ pos f t in
- (List.concat r, type_of)
-
- let uoperator : S.pos -> T.uoperator -> t -> t =
- fun pos op (r, expr1) -> (r, Type_of.Expression.uoperator pos op expr1)
-
- let boperator : S.pos -> T.boperator -> t -> t -> t =
- fun pos op (r1, expr1) (r2, expr2) ->
- (r1 @ r2, Type_of.Expression.boperator pos op expr1 expr2)
-end
+ [ msg ])
+ | _ -> []
+
+ let ident : (S.pos, Get_type.t * t) S.variable -> Get_type.t -> t =
+ fun variable _type_of ->
+ match variable.index with None -> [] | Some (_, t) -> t
+
+ let integer : S.pos -> string -> Get_type.t -> t =
+ fun pos t _type_of ->
+ ignore pos;
+ ignore t;
+ []
+
+ let function_ :
+ S.pos -> T.function_ -> (Get_type.t * t) list -> Get_type.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 * t -> Get_type.t -> t =
+ fun pos op r _type_of ->
+ ignore op;
+ ignore pos;
+ snd r
+
+ let boperator :
+ S.pos ->
+ T.boperator ->
+ Get_type.t * t ->
+ Get_type.t * t ->
+ Get_type.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' =
diff --git a/lib/syntax/t.ml b/lib/syntax/t.ml
index 7186275..38ad5b0 100644
--- a/lib/syntax/t.ml
+++ b/lib/syntax/t.ml
@@ -2,8 +2,15 @@
This module contains the basic operators used in the QSP syntax.
*)
+open StdLabels
+
type 'a literal = Text of string | Expression of 'a list
+let map_litteral : f:('a -> 'b) -> 'a literal -> 'b literal =
+ fun ~f -> function
+ | Text t -> Text t
+ | Expression e -> Expression (List.map ~f e)
+
type boperator =
| Eq
| Neq
diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml
index 15d6fe8..7b9a67e 100644
--- a/lib/syntax/type_of.ml
+++ b/lib/syntax/type_of.ml
@@ -5,20 +5,10 @@ let description = "Ensure all the expression are correctly typed"
let active = ref true
module Helper = struct
- 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 }]
-
- type t = Variable of type_of | Raw of type_of
- type argument_repr = { pos : S.pos; t : t }
+ type argument_repr = { pos : S.pos; t : Get_type.t }
module DynType = struct
- type nonrec t = t -> t
+ 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
@@ -42,14 +32,14 @@ module Helper = struct
- Either the type shall constrained by another one
- Or we have a variable number of arguments. *)
type argument =
- | Fixed of type_of
+ | Fixed of Get_type.type_of
| Dynamic of DynType.t
| Variable of argument
let compare :
?strict:bool ->
?level:Report.level ->
- type_of ->
+ Get_type.type_of ->
argument_repr ->
Report.t list ->
Report.t list =
@@ -94,8 +84,8 @@ module Helper = struct
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" pp_type_of expected
- pp_type_of result_type
+ 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
@@ -145,38 +135,39 @@ module Helper = struct
msg :: report
end
-module Expression = struct
- type state = { result : Helper.t; pos : S.pos; empty : bool }
- type t = state * Report.t list
- type t' = state * Report.t list
+module TypeBuilder = Compose.Expression (Get_type)
+
+type t' = { result : Get_type.t; pos : S.pos; empty : bool }
- let v : t -> t' = fun t -> t
+let arg_of_repr : Get_type.t -> S.pos -> Helper.argument_repr =
+ fun type_of pos -> { pos; t = type_of }
+
+module TypedExpression = struct
+ type nonrec t' = t' * Report.t list
+ type state = { pos : S.pos; empty : bool }
+ type t = state * Report.t list
- let arg_of_repr : state -> Helper.argument_repr =
- fun { result; pos; empty } ->
- ignore empty;
- { pos; t = result }
+ let v : Get_type.t * t -> t' =
+ fun (type_of, (t, r)) ->
+ ({ result = type_of; pos = t.pos; empty = t.empty }, r)
(** The variable has type string when starting with a '$' *)
- let ident : (S.pos, t) S.variable -> t =
- fun var ->
+ let ident : (S.pos, Get_type.t * t) S.variable -> Get_type.t -> t =
+ fun var _type_of ->
let empty = false in
(* Extract the error from the index *)
let report =
match var.index with
| None -> []
- | Some expr ->
+ | Some (_, expr) ->
let _, r = expr in
r
in
+ ({ pos = var.pos; empty }, report)
- match var.name.[0] with
- | '$' -> ({ result = Variable String; pos = var.pos; empty }, report)
- | _ -> ({ result = Variable Integer; pos = var.pos; empty }, report)
-
- let integer : S.pos -> string -> t =
- fun pos value ->
+ let integer : S.pos -> string -> Get_type.t -> t =
+ fun pos value _type_of ->
let int_value = int_of_string_opt value in
let empty, report =
@@ -186,30 +177,28 @@ module Expression = struct
| None -> (false, Report.error pos "Invalid integer value" :: [])
in
- ({ result = Raw Integer; pos; empty }, report)
+ ({ pos; empty }, report)
- let literal : S.pos -> t T.literal list -> t =
- fun pos values ->
- let init = ({ result = Raw Helper.NumericString; pos; empty = true }, []) in
+ let literal : S.pos -> (Get_type.t * t) T.literal list -> Get_type.t -> t =
+ fun pos values type_of ->
+ ignore type_of;
+ let init = ({ pos; empty = true }, []) in
let result =
- List.fold_left values ~init ~f:(fun (state, report) -> function
+ List.fold_left values ~init ~f:(fun (_, report) -> function
| T.Text t ->
let empty = String.equal t String.empty in
- let type_of =
- match int_of_string_opt t with
- | Some _ -> state.result
- | None -> Raw Helper.String
- in
- ({ result = type_of; pos; empty }, report)
- | T.Expression t ->
+ ({ pos; empty }, report)
+ | T.Expression (t : (Get_type.t * t) list) ->
(* Report the warning bottom top *)
let result, r =
List.fold_left t ~init:(None, [])
- ~f:(fun (_, report) (result, r) ->
+ ~f:(fun (_, report) (type_of, t) ->
+ ignore type_of;
+ let r = snd t in
let report = List.rev_append r report in
- (Some { result = result.result; pos; empty = false }, report))
+ (Some { pos; empty = false }, report))
in
- let default = { result = Raw Helper.String; pos; empty = true } in
+ let default = { pos; empty = true } in
let result = Option.value result ~default in
(result, r))
@@ -217,137 +206,146 @@ module Expression = struct
result
- let function_ : S.pos -> T.function_ -> t list -> t =
- fun pos function_ params ->
+ let function_ :
+ S.pos -> T.function_ -> (Get_type.t * t) list -> Get_type.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) param ->
+ 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 t in
+ let arg = arg_of_repr type_of t.pos in
(arg :: types, r @ report))
in
- let types = List.rev types
- and default = { result = Variable NumericString; pos; empty = false } in
+ let types = List.rev types and default = { pos; empty = false } in
match function_ with
| Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Getobj | Instr
| Isplay ->
- ({ default with result = Variable Integer }, report)
- | Desc' | Dyneval' | Getobj' ->
- ({ default with result = Variable String }, report)
- | Func | Func' -> ({ default with result = Variable NumericString }, report)
+ (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 *)
- let result = d (Raw Helper.Bool) in
- ({ result; pos; empty = false }, report)
+ ({ pos; empty = false }, 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
- ({ result = Variable NumericString; pos; empty = false }, report)
+ (default, report)
| Isnum ->
let expected = Helper.[ Fixed String ] in
let report = Helper.compare_args pos expected types report in
- ({ result = Raw Bool; pos; empty = false }, report)
+ (default, report)
| Lcase | Lcase' | Ucase | Ucase' ->
let expected = Helper.[ Fixed String ] in
let report = Helper.compare_args pos expected types report in
- ({ result = Raw String; pos; empty = false }, report)
+ (default, report)
| Len ->
let expected = Helper.[ Fixed NumericString ] in
let report = Helper.compare_args pos expected types report in
- ({ result = Raw Integer; pos; empty = false }, report)
+ (default, report)
| Loc ->
let expected = Helper.[ Fixed String ] in
let report = Helper.compare_args pos expected types report in
- ({ result = Variable Bool; pos; empty = false }, report)
+ (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
- let result = d (Raw Helper.Bool) in
- ({ result; pos; empty = false }, report)
+ ({ pos; empty = false }, report)
| Mid | Mid' ->
let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in
let report = Helper.compare_args pos expected types report in
- ({ result = Variable String; pos; empty = false }, report)
- | Msecscount -> ({ result = Raw Integer; pos; empty = false }, report)
+ (default, report)
+ | Msecscount -> (default, report)
| Rand ->
let expected = Helper.[ Variable (Fixed Integer) ] in
let report = Helper.compare_args pos expected types report in
- ({ result = Raw Integer; pos; empty = false }, report)
- | Replace -> ({ result = Variable String; pos; empty = false }, report)
- | Replace' -> ({ result = Variable String; pos; empty = false }, report)
- | Rgb -> ({ result = Raw Integer; pos; empty = false }, report)
+ (default, report)
+ | Replace -> (default, report)
+ | Replace' -> (default, report)
+ | Rgb -> (default, report)
| Qspver | Qspver' | Rnd ->
(* No arg *)
let report = Helper.compare_args pos [] types report in
- ({ result = Raw Integer; pos; empty = false }, report)
- | Selact -> ({ result = Variable String; pos; empty = false }, report)
- | Stattxt -> ({ result = Variable String; pos; empty = false }, report)
- | Stattxt' -> ({ result = Variable String; pos; empty = false }, report)
+ (default, report)
+ | Selact -> (default, report)
+ | Stattxt -> (default, report)
+ | Stattxt' -> (default, report)
| Str | Str' ->
let expected = Helper.[ Variable (Fixed Integer) ] in
let report = Helper.compare_args pos expected types report in
- ({ default with result = Raw String }, report)
- | Strcomp -> ({ result = Raw Bool; pos; empty = false }, report)
- | Strfind -> ({ result = Variable String; pos; empty = false }, report)
- | Strfind' -> ({ result = Variable String; pos; empty = false }, report)
- | Strpos -> ({ result = Raw Integer; pos; empty = false }, report)
- | Trim -> ({ result = Variable String; pos; empty = false }, report)
- | Trim' -> ({ result = Variable String; pos; empty = false }, report)
+ (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
- ({ result = Raw Integer; pos; empty = false }, report)
+ (default, report)
(** Unary operator like [-123] or [+'Text']*)
- let uoperator : S.pos -> T.uoperator -> t -> t =
- fun pos operator t1 ->
- let t, report = t1 in
+ let uoperator : S.pos -> T.uoperator -> Get_type.t * t -> Get_type.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 t ] in
+ 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
- ({ result = Raw Integer; pos; empty = false }, report)
+ ({ pos; empty = false }, report)
- let boperator : S.pos -> T.boperator -> t -> t -> t =
- fun pos operator t1 t2 ->
+ let boperator :
+ S.pos ->
+ T.boperator ->
+ Get_type.t * t ->
+ Get_type.t * t ->
+ Get_type.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 t1; arg_of_repr t2 ] in
+ let types = [ arg_of_repr type_1 t1.pos; arg_of_repr type_2 t2.pos ] in
match operator with
| T.Plus ->
let d = Helper.DynType.t () in
(* Remove the empty elements *)
let types =
- List.filter_map [ t1; t2 ] ~f:(fun t ->
+ List.filter_map
+ [ (type_1, t1); (type_2, t2) ]
+ ~f:(fun (type_of, t) ->
(* TODO could be added in the logs *)
- match t.empty with true -> None | false -> Some (arg_of_repr t))
+ match t.empty with
+ | true -> None
+ | false -> Some (arg_of_repr type_of t.pos))
in
let expected = List.map types ~f:(fun _ -> Helper.Dynamic d) in
let report = Helper.compare_args pos expected types report in
- let result = d Helper.(Variable Integer) in
- ({ result; pos; empty = false }, report)
+ ({ pos; empty = false }, report)
| T.Eq | T.Neq ->
(* If the expression is '' or 0, we accept the comparaison as if
instead of raising a warning *)
- if t1.empty || t2.empty then
- ({ result = Raw Bool; pos; empty = false }, report)
+ if t1.empty || t2.empty then ({ pos; empty = false }, report)
else
let d = Helper.(Dynamic (DynType.t ())) in
let expected = [ d; d ] in
@@ -355,24 +353,26 @@ module Expression = struct
Helper.compare_args ~strict:true pos expected (List.rev types)
report
in
- ({ result = Raw Bool; pos; empty = false }, report)
+ ({ pos; empty = false }, report)
| Lt | Gte | Lte | Gt ->
let d = Helper.(Dynamic (DynType.t ())) in
let expected = [ d; d ] in
let report = Helper.compare_args pos expected types report in
- ({ result = Raw Bool; pos; empty = false }, report)
+ ({ pos; empty = false }, 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
- ({ result = Raw Integer; pos; empty = false }, report)
+ ({ pos; empty = false }, 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
- ({ result = Raw Bool; pos; empty = false }, report)
+ ({ pos; empty = false }, report)
end
+module Expression = TypeBuilder.Make (TypedExpression)
+
module Instruction = struct
type t = Report.t list
type t' = Report.t list
@@ -401,7 +401,9 @@ module Instruction = struct
fun report (_pos, expr, instructions) ->
let result, r = expr in
- let r2 = Helper.compare Helper.Bool (Expression.arg_of_repr result) [] in
+ let r2 =
+ Helper.compare Get_type.Bool (arg_of_repr result.result result.pos) []
+ in
List.fold_left instructions
~init:(r @ r2 @ report)
@@ -431,7 +433,9 @@ module Instruction = struct
fun _pos ~label instructions ->
let result, report = label in
let report =
- Helper.compare Helper.String (Expression.arg_of_repr result) report
+ Helper.compare Get_type.String
+ (arg_of_repr result.result result.pos)
+ report
in
List.fold_left instructions ~init:report ~f:(fun acc a ->
@@ -446,13 +450,16 @@ module Instruction = struct
t =
fun pos variable _ expression ->
let right_expression, report = expression in
- let expr1, report' = Expression.ident variable in
- let report = report' @ report in
+
+ let report' = Option.map snd variable.index |> Option.value ~default:[] in
+
+ let report = List.rev_append report' report in
match right_expression.empty with
| true -> report
| false -> (
- let op1 = Expression.arg_of_repr expr1 in
- let op2 = Expression.arg_of_repr right_expression in
+ let var_type = 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 *)
@@ -483,6 +490,3 @@ module Location = struct
in
report
end
-
-let get_type : Expression.t' -> Helper.type_of =
- fun t' -> match (fst t').result with Raw r -> r | Variable r -> r
diff --git a/lib/syntax/type_of.mli b/lib/syntax/type_of.mli
index a009c48..551f9ac 100644
--- a/lib/syntax/type_of.mli
+++ b/lib/syntax/type_of.mli
@@ -1,11 +1,3 @@
-module Helper : sig
- type type_of =
- | Integer (** A numeric value *)
- | Bool (** A boolean, not a real type *)
- | String (** String value *)
- | NumericString
-end
-
include S.Analyzer
(** The module [type_of] populate the report with differents inconsistency
errors in the types.
@@ -13,5 +5,3 @@ include S.Analyzer
- 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. *)
-
-val get_type : Expression.t' -> Helper.type_of