diff options
Diffstat (limited to 'syntax/type_of.ml')
| -rw-r--r-- | syntax/type_of.ml | 348 |
1 files changed, 348 insertions, 0 deletions
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 |